d328d80 · typeable/servant-reflex

git.iko.soy/typeable/servant-reflex

Finish converting to new-reflex-dom

commitd328d80b851786ea1eebac167cf909170a0b2694 authorDoug Beardsley <mightybyte@gmail.com> dateFri 8 Jul 2016, 00:32 (10 years ago) parent32aceb6

5 files changed+78−76

compare with master

unifiedsplit

exec/API.hs+5−4 exec/Example.hs+26−17 servant-reflex.cabal+1−1 src/Servant/Common/Req.hs+21−19 src/Servant/Reflex.hs+25−35

exec/API.hs+5−4

@@ -3,18 +3,19 @@

44module API where

6+import Data.Text (Text)

67import Servant.API

89-- | API spec for server, client, and docs

910type API = "getunit" :> Get '[JSON] ()

1011 :<|> "getint" :> Get '[JSON] Int

11− :<|> "sayhi" :> QueryParam "username" String

12− :> QueryParams "greetings" String

12+ :<|> "sayhi" :> QueryParam "username" Text

13+ :> QueryParams "greetings" Text

1314 :> QueryFlag "gusto"

14− :> Get '[JSON] String

15+ :> Get '[JSON] Text

1516 :<|> "double" :> ReqBody '[JSON] Double

1617 :> Post '[JSON] Double

17− :<|> "a" :> "b" :> QueryFlag "gusto" :> Get '[JSON] String

18+ :<|> "a" :> "b" :> QueryFlag "gusto" :> Get '[JSON] Text

1819 :<|> Raw

1920

2021type GET = Get '[JSON] ()

exec/Example.hs+26−17

@@ -1,10 +1,16 @@

1+{-# LANGUAGE FlexibleContexts #-}

2+{-# LANGUAGE GADTs #-}

3+{-# LANGUAGE OverloadedStrings #-}

4+{-# LANGUAGE RankNTypes #-}

15{-# LANGUAGE ScopedTypeVariables #-}

2−{-# LANGUAGE RankNTypes #-}

47module Main where

69import Data.Bool

710import Data.Maybe

11+import Data.Monoid

12+import Data.Text (Text)

13+import qualified Data.Text as T

814import Servant.API

915import Servant.Reflex

1016import API

@@ -52,13 +58,13 @@ run = do

5258

5359 text "Name"

5460 el "br" $ return ()

55− inp :: Dynamic t String <- fmap value (textInput def)

56− let checkedName = fmap (\i -> bool (Right i) (Left "Need a name") (null i)) (current inp)

61+ inp :: Dynamic t Text <- fmap value (textInput def)

62+ let checkedName = fmap (\i -> bool (Right i) (Left "Need a name") (T.null i)) (current inp)

5763 el "br" $ return ()

5864

5965 text "Greetings (space-separated)"

6066 el "br" $ return ()

61− greetings <- fmap (fmap words . current . value) (textInput def)

67+ greetings <- fmap (fmap T.words . current . value) (textInput def)

6268

6369 el "br" $ return ()

6470

@@ -75,27 +81,30 @@ run = do

7581 el "br" $ return ()

7682 dblinp <- value <$> textInput def

7783 dblBtn <- button "Double it"

78− dblResp <- dbl (fmap (note "read failure" . readMaybe) $ current dblinp) dblBtn

84+ dblResp <- dbl (fmap (note "read failure" . readMaybe . T.unpack) $ current dblinp) dblBtn

7985 dynText =<< holdDyn "(no errors)" (fmapMaybe reqFailure dblResp)

8086 el "br" (return ())

81− display =<< holdDyn "No number yet" (fmap show $ fmapMaybe reqSuccess dblResp)

87+ display =<< holdDyn "No number yet" (fmap tShow $ fmapMaybe reqSuccess dblResp)

8288

8389 elClass "div" "demo-group" $ do

8490 text "Multi-part path"

8591 b <- (current . value) <$> checkbox False def

8692 mpGo <- button "Test"

8793 multiResp <- multi b mpGo

88− dynText =<< holdDyn "No res yet" (fmap show $ fmapMaybe reqSuccess $ multiResp)

94+ dynText =<< holdDyn "No res yet" (fmap tShow $ fmapMaybe reqSuccess $ multiResp)

8995

90−showXhrResponse :: XhrResponse -> String

96+showXhrResponse :: XhrResponse -> Text

9197showXhrResponse (XhrResponse stat stattxt rbmay rtmay) =

92− unlines ["stat: " ++ show stat

93− ,"stattxt: " ++ show stattxt

94− ,"resp: " ++ maybe "" showRB rbmay

95− ,"rtext: " ++ show rtmay]

96−

97−showRB :: XhrResponseBody -> String

98−showRB (XhrResponseBody_Default t) = show t

99−showRB (XhrResponseBody_Text t) = show t

98+ T.unlines ["stat: " <> tShow stat

99+ ,"stattxt: " <> tShow stattxt

100+ ,"resp: " <> maybe "" showRB rbmay

101+ ,"rtext: " <> tShow rtmay]

102+

103+tShow :: Show a => a -> Text

104+tShow = T.pack . show

105+

106+showRB :: XhrResponseBody -> Text

107+showRB (XhrResponseBody_Default t) = tShow t

108+showRB (XhrResponseBody_Text t) = tShow t

100109showRB (XhrResponseBody_Blob t) = "<Blob>"

101−showRB (XhrResponseBody_ArrayBuffer t) = show t

110+showRB (XhrResponseBody_ArrayBuffer t) = tShow t

servant-reflex.cabal+1−1

@@ -48,7 +48,7 @@ library

4848 default-language: Haskell2010

4949

5050executable example

51− build-depends: reflex, servant-reflex, base, scientific, servant, reflex-dom

51+ build-depends: reflex, servant-reflex, base, scientific, servant, reflex-dom, text

5252 default-language: Haskell2010

5353 main-is: Example.hs

5454 other-modules: API

src/Servant/Common/Req.hs+21−19

@@ -13,9 +13,11 @@ import qualified Data.ByteString.Lazy.Char8 as BL

1313import Data.Maybe

1414import Data.Monoid

1515import qualified Data.Text.Encoding as TE

16+import qualified Data.Text.Lazy.Encoding as LTE

1617-- import qualified Data.Foldable as F

1718import Data.Text (Text)

1819import qualified Data.Text as T

20+import qualified Data.Text.Lazy as LT

1921import Data.Proxy

2022import qualified Data.Map as Map

2123-- import Data.Monoid

@@ -37,7 +39,6 @@ import Reflex

3739import Reflex.Dom

3840

3941import Servant.API.BasicAuth

40−import qualified Data.ByteString.Char8 as BS

4142

4243-- import qualified Network.HTTP.Client as Client

4344

@@ -84,7 +85,7 @@ prependToPathParts p req =

8485

8586addHeader :: (ToHttpApiData a, Reflex t) => Text -> Behavior t (Either Text a) -> Req t -> Req t

8687addHeader name val req = req { headers = headers req

87− <> [(name, fmap (toHeader) val)]

88+ <> [(name, fmap (TE.decodeUtf8 . toHeader) val)]

8889-- <> [(name, (fmap . fmap) (decodeUtf8 . toHeader) val)]

8990 }

9091

@@ -102,7 +103,7 @@ performRequest :: forall t m.MonadWidget t m

102103 -> m (Event t XhrResponse, Event t Text)

103104 -- -> ExceptT ServantError IO ( Int, ByteString, MediaType

104105 -- , [HTTP.Header], Response ByteString)

105−performRequest reqMethod req reqHost trigger = do

106+performRequest reqMeth req reqHost trigger = do

106107

107108 -- Ridiculous functor-juggling! How to clean this up?

108109 let t :: Behavior t [Either Text Text]

@@ -137,7 +138,7 @@ performRequest reqMethod req reqHost trigger = do

137138 queryString :: Behavior t (Either Text Text) =

138139 ffor queryPartStrings' $ \qs -> fmap (T.intercalate "&") qs

139140-- ffor queryPartStrings' $ \qs -> fmap (T.intercalate "&") (sequence qs)

140− xhrUrl = (liftA3 . liftA3) (\a p q -> a </> if null q then p else p <> "?" <> q) baseUrl urlPath queryString

141+ xhrUrl = (liftA3 . liftA3) (\a p q -> a </> if T.null q then p else p <> "?" <> q) baseUrl urlPath queryString

141142 where

142143 (</>) :: Text -> Text -> Text

143144 x </> y | ("/" `T.isSuffixOf` x) || ("/" `T.isPrefixOf` y) = x <> y

@@ -146,38 +147,39 @@ performRequest reqMethod req reqHost trigger = do

146147 xhrHeaders :: Behavior t [(Text, Text)]

147148 xhrHeaders = sequence $ ffor (headers req) $ \(hName, hVal) -> fmap (hName,) hVal

148149

149− mkConfigBody :: [(Text,Text)] -> (Either Text (BL.ByteString, Text)) -> Either Text (XhrRequestConfig x)

150− mkConfigBody hs rb = case rb of

150+ mkConfigBody :: [(Text,Text)] -> (Either Text (BL.ByteString, Text)) -> Either Text (XhrRequestConfig LT.Text)

151+ mkConfigBody _ rb = case rb of

151152 Left e -> Left e

152153 (Right (bBytes, bCT)) ->

153− Right $ def { _xhrRequestConfig_sendData = Just (BL.unpack bBytes)

154+ Right $ def { _xhrRequestConfig_sendData = LTE.decodeUtf8 bBytes

154155 , _xhrRequestConfig_headers =

155156 Map.insert "Content-Type" bCT (_xhrRequestConfig_headers def)}

156157

157− xhrOpts :: Behavior t (Either Text (XhrRequestConfig x))

158+ xhrOpts :: Behavior t (Either Text (XhrRequestConfig LT.Text))

158159 xhrOpts = case reqBody req of

159− Nothing -> fmap (\h -> Right $ def { _xhrRequestConfig_headers = Map.fromList h }) xhrHeaders

160+ Nothing -> fmap (\h -> Right $ XhrRequestConfig

161+ (Map.fromList h) Nothing Nothing Nothing "") xhrHeaders

160162 Just rBody -> liftA2 mkConfigBody xhrHeaders rBody

161163

162164 mkAuth :: Maybe BasicAuthData -> Either Text (XhrRequestConfig x) -> Either Text (XhrRequestConfig x)

163165 mkAuth _ (Left e) = Left e

164166 mkAuth Nothing r = r

165167 mkAuth (Just (BasicAuthData u p)) (Right config) = Right $ config

166− { _xhrRequestConfig_user = Just $ BS.unpack u

167− , _xhrRequestConfig_password = Just $ BS.unpack p}

168+ { _xhrRequestConfig_user = Just $ TE.decodeUtf8 u

169+ , _xhrRequestConfig_password = Just $ TE.decodeUtf8 p}

168170

169171 addAuth :: Behavior t (Either Text (XhrRequestConfig x)) -> Behavior t (Either Text (XhrRequestConfig x))

170172 addAuth xhr = case authData req of

171173 Nothing -> xhr

172174 Just auth -> liftA2 mkAuth auth xhr

173175

174− xhrReq = (liftA2 . liftA2) (\p opt -> XhrRequest reqMethod p opt) xhrUrl (addAuth xhrOpts)

176+ xhrReq = (liftA2 . liftA2) (\p opt -> XhrRequest reqMeth p opt) xhrUrl (addAuth xhrOpts)

175177

176178 let reqs = tag xhrReq trigger

177179 okReqs = fmapMaybe (either (const Nothing) Just) reqs

178180 badReqs = fmapMaybe (either Just (const Nothing)) reqs

179181

180− resps <- performRequestAsync okReqs

182+ resps <- performRequestAsync (fmap LT.unpack <$> okReqs)

181183 return (resps, badReqs)

182184

183185 -- let oneNamedPair :: String -> [QueryPart] -> String

@@ -203,22 +205,22 @@ performRequestNoBody ::

203205 forall t m .MonadWidget t m => Text -> Req t -> Dynamic t BaseUrl

204206-- -> Event t () -> m (Event t (Maybe NoContent, XhrResponse))

205207 -> Event t () -> m (Event t (ReqResult NoContent))

206−performRequestNoBody reqMethod req reqHost trigger = do

207− -- performRequest reqMethod req reqHost trigger

208+performRequestNoBody _ _ _ _ = do

209+ -- performRequest reqMeth req reqHost trigger

208210 undefined

209211 -- return hdrs

210212

211213performRequestCT :: (MonadWidget t m, MimeUnrender ct a)

212214 => Proxy ct -> Text -> Req t -> Dynamic t BaseUrl

213215 -> Event t () -> m (Event t (ReqResult a))

214−performRequestCT ct reqMethod req reqHost trigger = do

215− (resp, badReq) <- performRequest reqMethod req reqHost trigger

216+performRequestCT ct reqMeth req reqHost trigger = do

217+ (resp, badReq) <- performRequest reqMeth req reqHost trigger

216218 let decodes = ffor resp $ \xhr ->

217219 ((mimeUnrender ct . BL.fromStrict . TE.encodeUtf8)

218220 =<< note "No body text" (_xhrResponse_responseText xhr), xhr)

219221 reqs = ffor decodes $ \case

220− (Right a, resp) -> ResponseSuccess a resp

221− (Left e, resp) -> ResponseFailure e resp

222+ (Right a, r) -> ResponseSuccess a r

223+ (Left e, r) -> ResponseFailure (T.pack e) r

222224 return $ leftmost [reqs, fmap RequestFailure badReq]

223225

224226note :: e -> Maybe a -> Either e a

src/Servant/Reflex.hs+25−35

@@ -23,26 +23,18 @@ module Servant.Reflex

2323 , module Servant.Common.BaseUrl

2424 ) where

2525

26−import Control.Applicative ((<$>), liftA2)

27−import Control.Monad.Trans.Except

28−import qualified Data.ByteString.Char8 as BS

29−import Data.ByteString.Lazy (ByteString)

30−import qualified Data.CaseInsensitive as CI

31−import Data.List

26+import Control.Applicative

3227import Data.Proxy

3328import Data.String.Conversions

34−import Data.Maybe (maybeToList)

35−import Data.Text (unpack)

36−import Data.Traversable (sequenceA)

29+import Data.Text (Text)

30+import qualified Data.Text as T

31+import Data.Text.Encoding

3732import GHC.TypeLits

38−import qualified Network.HTTP.Media as M

3933import Servant.API

4034import Servant.Common.BaseUrl

4135import Servant.Common.Req

42−import Servant.API.ContentTypes

4336import Reflex

4437import Reflex.Dom

45−import Reflex.Dom.Xhr

4638

4739-- * Accessing APIs as a Client

4840

@@ -92,7 +84,7 @@ instance (MonadWidget t m, KnownSymbol capture, ToHttpApiData a, HasClient t m s

9284 => HasClient t m (Capture capture a :> sublayout) where

9385

9486 type Client t m (Capture capture a :> sublayout) =

95− Behavior t (Either String a) -> Client t m sublayout

87+ Behavior t (Either Text a) -> Client t m sublayout

9688

9789 clientWithRoute Proxy q req baseurl val =

9890 clientWithRoute (Proxy :: Proxy sublayout)

@@ -100,7 +92,7 @@ instance (MonadWidget t m, KnownSymbol capture, ToHttpApiData a, HasClient t m s

10092 (prependToPathParts p req)

10193 baseurl

10294

103− where p = (fmap . fmap) (unpack . toUrlPiece) val

95+ where p = (fmap . fmap) (toUrlPiece) val

10496

10597-- VERB (Returning content) --

10698instance {-# OVERLAPPABLE #-}

@@ -111,9 +103,9 @@ instance {-# OVERLAPPABLE #-}

111103 Event t () -> m (Event t (ReqResult a))

112104 -- TODO how to access input types here?

113105 -- ExceptT ServantError IO a

114− clientWithRoute Proxy q req baseurl =

106+ clientWithRoute Proxy _ req baseurl =

115107 performRequestCT (Proxy :: Proxy ct) method req' baseurl

116− where method = BS.unpack $ reflectMethod (Proxy :: Proxy method)

108+ where method = decodeUtf8 $ reflectMethod (Proxy :: Proxy method)

117109 req' = req { reqMethod = method }

118110

119111-- -- VERB (No content) --

@@ -124,9 +116,9 @@ instance {-# OVERLAPPING #-}

124116 Event t () -> m (Event t (ReqResult NoContent))

125117 -- TODO: how to access input types here?

126118 -- ExceptT ServantError IO NoContent

127− clientWithRoute Proxy q req baseurl =

119+ clientWithRoute Proxy _ req baseurl =

128120 performRequestNoBody method req baseurl

129− where method = BS.unpack $ reflectMethod (Proxy :: Proxy method)

121+ where method = decodeUtf8 $ reflectMethod (Proxy :: Proxy method)

130122

131123-- -- HEADERS Verb (Content) --

132124-- -- Headers combinator not treated in fully general case,

@@ -184,9 +176,9 @@ instance (KnownSymbol sym, ToHttpApiData a,

184176 => HasClient t m (Header sym a :> sublayout) where

185177

186178 type Client t m (Header sym a :> sublayout) =

187− Behavior t (Either String a) -> Client t m sublayout

179+ Behavior t (Either Text a) -> Client t m sublayout

188180

189− clientWithRoute Proxy q req baseurl mval =

181+ clientWithRoute Proxy q req baseurl _ =

190182 clientWithRoute (Proxy :: Proxy sublayout)

191183 q

192184 req

@@ -196,8 +188,6 @@ instance (KnownSymbol sym, ToHttpApiData a,

196188 -- )

197189 baseurl

198190

199− where hname = symbolVal (Proxy :: Proxy sym)

200−

201191-- | Using a 'HttpVersion' combinator in your API doesn't affect the client

202192-- functions.

203193instance HasClient t m sublayout

@@ -240,7 +230,7 @@ instance (KnownSymbol sym, ToHttpApiData a, HasClient t m sublayout, Reflex t)

240230

241231 type Client t m (QueryParam sym a :> sublayout) =

242232 -- TODO (Maybe a), or (Maybe (Maybe a))? (should the user be able to send a Nothing)

243− Behavior t (Either String a) -> Client t m sublayout

233+ Behavior t (Either Text a) -> Client t m sublayout

244234

245235 -- if mparam = Nothing, we don't add it to the query string

246236 clientWithRoute Proxy q req baseurl mparam =

@@ -248,8 +238,8 @@ instance (KnownSymbol sym, ToHttpApiData a, HasClient t m sublayout, Reflex t)

248238 (req {qParams = paramPair : qParams req}) baseurl

249239

250240 where pname = symbolVal (Proxy :: Proxy sym)

251− p prm = QueryPartParam $ (fmap . fmap) (unpack . toQueryParam) prm

252− paramPair = (pname, p mparam)

241+ p prm = QueryPartParam $ (fmap . fmap) (toQueryParam) prm

242+ paramPair = (T.pack pname, p mparam)

253243

254244-- | If you use a 'QueryParams' in one of your endpoints in your API,

255245-- the corresponding querying function will automatically take

@@ -288,9 +278,9 @@ instance (KnownSymbol sym, ToHttpApiData a, HasClient t m sublayout, Reflex t)

288278 clientWithRoute Proxy q req baseurl paramlist =

289279 clientWithRoute (Proxy :: Proxy sublayout) q req' baseurl

290280

291− where req' = req { qParams = (pname, params') : qParams req }

281+ where req' = req { qParams = (T.pack pname, params') : qParams req }

292282 pname = symbolVal (Proxy :: Proxy sym)

293− params' = QueryPartParams $ (fmap . fmap) (unpack . toQueryParam)

283+ params' = QueryPartParams $ (fmap . fmap) (toQueryParam)

294284 paramlist

295285

296286

@@ -328,7 +318,7 @@ instance (KnownSymbol sym, HasClient t m sublayout, Reflex t)

328318 clientWithRoute (Proxy :: Proxy sublayout) q req' baseurl

329319

330320 where req' = req { qParams = thisPair : qParams req }

331− thisPair = (pName, QueryPartFlag flag) :: (String, QueryPart t)

321+ thisPair = (T.pack pName, QueryPartFlag flag) :: (Text, QueryPart t)

332322 pName = symbolVal (Proxy :: Proxy sym)

333323

334324

@@ -336,16 +326,16 @@ instance (KnownSymbol sym, HasClient t m sublayout, Reflex t)

336326-- back the full `Response`.

337327-- TODO redo

338328instance (MonadWidget t m) => HasClient t m Raw where

339− type Client t m Raw = Behavior t (Either String XhrRequest)

329+ type Client t m Raw = Behavior t (Either Text (XhrRequest ()))

340330 -> Event t ()

341331 -> m (Event t (ReqResult ()))

342332

343333 -- clientWithRoute :: Proxy Raw -> Proxy m -> Req -> BaseUrl -> Client t m Raw

344− clientWithRoute p q req baseurl xhrs triggers = do

334+ clientWithRoute _ _ _ baseurl xhrs triggers = do

345335 let xhrs' = liftA2 (\x path -> case x of

346336 Left e -> Left e

347337 Right jx -> Right $ jx {_xhrRequest_url = path

348− ++ _xhrRequest_url jx})

338+ <> _xhrRequest_url jx})

349339 xhrs

350340 (showBaseUrl <$> current baseurl)

351341 reqs = tag xhrs' triggers

@@ -386,14 +376,14 @@ instance (MimeRender ct a, HasClient t m sublayout, Reflex t)

386376 => HasClient t m (ReqBody (ct ': cts) a :> sublayout) where

387377

388378 type Client t m (ReqBody (ct ': cts) a :> sublayout) =

389− Behavior t (Either String a) -> Client t m sublayout

379+ Behavior t (Either Text a) -> Client t m sublayout

390380

391381 clientWithRoute Proxy q req baseurl body =

392382 clientWithRoute (Proxy :: Proxy sublayout) q req' baseurl

393383 where req' = req { reqBody = bodyBytesCT }

394384 ctProxy = Proxy :: Proxy ct

395− ctString = show $ contentType ctProxy

396− --ctString = BS.unpack . CI.original . M.mainType $ contentType ctProxy

385+ ctString = T.pack $ show $ contentType ctProxy

386+ --ctString = decodeUtf8 . CI.original . M.mainType $ contentType ctProxy

397387 bodyBytesCT = Just $ (fmap . fmap)

398388 (\b -> (mimeRender ctProxy b, ctString))

399389 body

@@ -404,7 +394,7 @@ instance (KnownSymbol path, HasClient t m sublayout, Reflex t) => HasClient t m

404394

405395 clientWithRoute Proxy q req baseurl =

406396 clientWithRoute (Proxy :: Proxy sublayout) q

407− (prependToPathParts (constant (Right p)) req)

397+ (prependToPathParts (constant (Right $ T.pack p)) req)

408398 baseurl

409399

410400 where p = symbolVal (Proxy :: Proxy path)