e38593f · servant-reflex

git.iko.soy/servant-reflex

Testing jsdonDecode

Relies on this PR https://github.com/reflex-frp/reflex-dom/pull/155

commite38593f0acd0584ba064ccb547436522fea1bd08 authorLuigy Leon <luigy@outlook.com> dateThu 15 Jun 2017, 11:25 (9 years ago) parent640f27e

4 files changed+28−13

compare with master

unifiedsplit

servant-reflex.cabal+1 src/Servant/Common/Req.hs+20−11 src/Servant/Reflex.hs+4−2 src/Servant/Reflex/Multi.hs+3

servant-reflex.cabal+1

@@ -27,6 +27,7 @@ library

2727 hs-source-dirs: src

2828 build-depends:

2929 base >= 4.8 && < 4.10,

30+ aeson >= 0.11 && < 1.0,

3031 bytestring >= 0.10 && < 0.11,

3132 case-insensitive >= 1.2.0.4 && < 1.3,

3233 containers >= 0.5.6 && < 0.6,

src/Servant/Common/Req.hs+20−11

@@ -14,6 +14,7 @@ import Control.Concurrent

1414import Control.Applicative (liftA2, liftA3)

1515import Control.Monad (join)

1616import Control.Monad.IO.Class (MonadIO, liftIO)

17+import Data.Aeson

1718import Data.Bifunctor (first)

1819import qualified Data.ByteString.Lazy.Char8 as BL

1920import qualified Data.Map as Map

@@ -26,6 +27,8 @@ import qualified Data.Text as T

2627import qualified Data.Text.Encoding as TE

2728import Data.Traversable (forM)

2829import Language.Javascript.JSaddle.Monad (JSM, MonadJSM)

30+import qualified Language.Javascript.JSaddle as JS

31+import Language.Javascript.JSaddle.Types (JSVal)

2932import Reflex.Dom hiding (tag)

3033import Servant.Common.BaseUrl (BaseUrl, showBaseUrl,

3134 SupportsServantReflex)

@@ -347,23 +350,29 @@ bytesToPayload = TE.decodeUtf8 . BL.toStrict

347350-- , fmap (uncurry RequestFailure) badReq

348351-- ]

349352

350−

351353performRequestsCT

352− :: (SupportsServantReflex t m,

353− MimeUnrender ct a, Traversable f)

354+ :: ( SupportsServantReflex t m

355+ -- , MimeUnrender ct a

356+ , FromJSON a

357+ , Traversable f

358+ )

354359 => Proxy ct

355360 -> Text

356361 -> Dynamic t (f (Req t))

357362 -> Dynamic t BaseUrl

358363 -> Event t tag

359364 -> m (Event t (f (ReqResult tag a)))

360−performRequestsCT ct reqMeth reqs reqHost trigger = do

365+performRequestsCT _ reqMeth reqs reqHost trigger = do

361366 resps <- performRequests reqMeth reqs reqHost trigger

362− let decodeResp x = first T.pack .

363− mimeUnrender ct .

364− BL.fromStrict .

365− TE.encodeUtf8 =<< note "No body text"

366− (_xhrResponse_responseText x)

367+ -- let decodeResp x = first T.pack .

368+ -- mimeUnrender ct .

369+ -- BL.fromStrict .

370+ -- TE.encodeUtf8 =<< note "No body text"

371+ let decodeResp x = first T.pack

372+ . note "Failed to decode"

373+ . jsonDecode

374+ . JS.textToJSString

375+ =<< note "No body text" (_xhrResponse_responseText x)

367376 return $ fmap

368377 (\(t,rs) -> ffor rs $ \r -> case r of

369378 Left e -> RequestFailure t e

@@ -393,7 +402,7 @@ evalResponse

393402 :: (XhrResponse -> Either Text a)

394403 -> (tag, XhrResponse)

395404 -> ReqResult tag a

396−evalResponse decode (tag, xhr) =

405+evalResponse decodeRes (tag, xhr) =

397406 let okStatus = _xhrResponse_status xhr < 400

398407 errMsg = fromMaybe

399408 ("Empty response with error code " <>

@@ -403,7 +412,7 @@ evalResponse decode (tag, xhr) =

403412 then either

404413 (\e -> ResponseFailure tag e xhr)

405414 (\v -> ResponseSuccess tag v xhr)

406− (decode xhr)

415+ (decodeRes xhr)

407416 else ResponseFailure tag errMsg xhr

408417 in respPayld

409418

src/Servant/Reflex.hs+4−2

@@ -34,6 +34,7 @@ module Servant.Reflex

3434 ) where

3535

3636------------------------------------------------------------------------------

37+import Data.Aeson

3738import Control.Applicative

3839import Data.Monoid ((<>))

3940import qualified Data.Set as Set

@@ -128,7 +129,7 @@ instance (HasClient t m a tag, HasClient t m b tag) => HasClient t m (a :<|> b)

128129-- -> m (Event t (l, ReqResult Book))

129130-- > getBook = client myApi (constDyn host)

130131

131−instance (SupportsServantReflex t m, ToHttpApiData a, HasClient t m sublayout tag)

132+instance (SupportsServantReflex t m, FromJSON a, ToHttpApiData a, HasClient t m sublayout tag)

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

133134

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

@@ -145,7 +146,7 @@ instance (SupportsServantReflex t m, ToHttpApiData a, HasClient t m sublayout ta

145146-- VERB (Returning content) --

146147instance {-# OVERLAPPABLE #-}

147148 -- Note [Non-Empty Content Types]

148− (MimeUnrender ct a, ReflectMethod method, cts' ~ (ct ': cts), SupportsServantReflex t m

149+ (FromJSON a, MimeUnrender ct a, ReflectMethod method, cts' ~ (ct ': cts), SupportsServantReflex t m

149150 ) => HasClient t m (Verb method status cts' a) tag where

150151 type Client t m (Verb method status cts' a) tag =

151152 Event t tag -> m (Event t (ReqResult tag a))

@@ -198,6 +199,7 @@ instance {-# OVERLAPPABLE #-} (BuildHeaderKeysTo xs, KnownSymbol h)

198199instance {-# OVERLAPPABLE #-}

199200 -- Note [Non-Empty Content Types]

200201 ( MimeUnrender ct a, BuildHeadersTo ls, BuildHeaderKeysTo ls,

202+ FromJSON a,

201203 ReflectMethod method, cts' ~ (ct ': cts),

202204 SupportsServantReflex t m

203205 ) => HasClient t m (Verb method status cts' (Headers ls a)) tag where

src/Servant/Reflex/Multi.hs+3

@@ -34,6 +34,7 @@ module Servant.Reflex.Multi (

3434 ) where

3535

3636------------------------------------------------------------------------------

37+import Data.Aeson

3738import Control.Applicative (liftA2)

3839import Data.Functor.Compose (Compose (..), getCompose)

3940import Data.Proxy (Proxy (..))

@@ -119,6 +120,7 @@ instance (SupportsServantReflex t m,

119120instance {-# OVERLAPPABLE #-}

120121 -- Note [Non-Empty Content Types]

121122 (MimeUnrender ct a,

123+ FromJSON a,

122124 ReflectMethod method, cts' ~ (ct ': cts),

123125 SupportsServantReflex t m,

124126 Applicative f,

@@ -152,6 +154,7 @@ instance {-# OVERLAPPING #-}

152154instance {-# OVERLAPPABLE #-}

153155 -- Note [Non-Empty Content Types]

154156 ( MimeUnrender ct a, BuildHeadersTo ls, BuildHeaderKeysTo ls,

157+ FromJSON a,

155158 ReflectMethod method, cts' ~ (ct ': cts),

156159 SupportsServantReflex t m,

157160 Traversable f