c6e25e9 · servant-reflex

git.iko.soy/servant-reflex

empass of existentialization

commitc6e25e9a48fde3a6708dde8edbb75f4d27909e3d authorIsaac Shapira <fresheyeball@gmail.com> dateWed 28 Feb 2018, 13:59 (9 years ago) parentdd16ebb

2 files changed+121−118

compare with master

unifiedsplit

src/Servant/Common/Req.hs+79−70 src/Servant/Reflex.hs+42−48

src/Servant/Common/Req.hs+79−70

@@ -1,56 +1,60 @@

1−{-# LANGUAGE CPP #-}

2−{-# LANGUAGE DeriveFunctor #-}

3−{-# LANGUAGE FlexibleContexts #-}

4−{-# LANGUAGE GADTs #-}

5−{-# LANGUAGE OverloadedStrings #-}

6−{-# LANGUAGE LambdaCase #-}

7−{-# LANGUAGE RankNTypes #-}

8−{-# LANGUAGE ScopedTypeVariables #-}

9−{-# LANGUAGE TupleSections #-}

10−

11−{-# LANGUAGE MultiParamTypeClasses #-}

12−{-# LANGUAGE FlexibleInstances #-}

1+{-# LANGUAGE CPP #-}

2+{-# LANGUAGE DeriveFunctor #-}

3+{-# LANGUAGE ExistentialQuantification #-}

4+{-# LANGUAGE FlexibleContexts #-}

5+{-# LANGUAGE FlexibleInstances #-}

6+{-# LANGUAGE FunctionalDependencies #-}

7+{-# LANGUAGE GADTs #-}

8+{-# LANGUAGE LambdaCase #-}

9+{-# LANGUAGE MultiParamTypeClasses #-}

10+{-# LANGUAGE OverloadedStrings #-}

11+{-# LANGUAGE RankNTypes #-}

12+{-# LANGUAGE ScopedTypeVariables #-}

13+{-# LANGUAGE TupleSections #-}

14+

1315module Servant.Common.Req where

1416

1517-------------------------------------------------------------------------------

16−import Control.Applicative (liftA2, liftA3)

18+import Control.Applicative (liftA2, liftA3)

1719import Control.Concurrent

18−import Control.Monad (join)

19−import Control.Monad.IO.Class (MonadIO, liftIO)

20+import Control.Monad (join)

21+import Control.Monad.IO.Class (MonadIO, liftIO)

2022import Data.Aeson

21−import Data.Bifunctor (first)

22−import qualified Data.ByteString.Builder as BB

23−import qualified Data.ByteString as BS

24−import Data.ByteString.Lazy (ByteString)

25−import qualified Data.ByteString.Lazy.Char8 as BL

26−import qualified Data.Map as Map

27−import Data.Maybe (catMaybes, fromMaybe)

23+import Data.Bifunctor (first)

24+import qualified Data.ByteString as BS

25+import qualified Data.ByteString.Builder as BB

26+import Data.ByteString.Lazy (ByteString)

27+import qualified Data.ByteString.Lazy.Char8 as BL

2828import Data.Functor.Compose

29−import Data.Monoid ((<>))

30−import Data.Proxy (Proxy(..))

31−import Data.Text (Text)

32−import qualified Data.Text as T

33−import qualified Data.Text.Lazy as TL

34−import qualified Data.Text.Encoding as T

35−import Data.Traversable (forM)

29+import qualified Data.JSString.Text as JS (lazyTextFromJSString)

30+import qualified Data.Map as Map

31+import Data.Maybe (catMaybes, fromMaybe)

32+import Data.Monoid ((<>))

33+import Data.Proxy (Proxy (..))

34+import Data.Text (Text)

35+import qualified Data.Text as T

36+import qualified Data.Text.Encoding as T

37+import qualified Data.Text.Lazy as TL

38+import Data.Traversable (forM)

39+import GHCJS.DOM.Types (Blob, Document, FormData)

40+import qualified Language.Javascript.JSaddle as JS

3641import Language.Javascript.JSaddle.Monad (JSM, MonadJSM, liftJSM)

37−import qualified Language.Javascript.JSaddle as JS

38−import qualified Data.JSString.Text as JS (lazyTextFromJSString)

39−import qualified Network.URI as N

40−import Reflex.Dom.Core hiding (tag)

41−import Servant.Common.BaseUrl (BaseUrl, showBaseUrl,

42− SupportsServantReflex)

43−import Servant.API.ContentTypes ( NoContent(..), Accept, JSON

44− , OctetStream, PlainText

45− , FormUrlEncoded)

46−import Web.HttpApiData (ToHttpApiData(..))

47−import Web.FormUrlEncoded (FromForm, urlDecodeAsForm)

42+import qualified Network.URI as N

43+import Reflex.Dom.Core hiding (tag)

44+import Servant.API.ContentTypes (Accept, FormUrlEncoded,

45+ JSON, NoContent (..),

46+ OctetStream, PlainText)

47+import Servant.Common.BaseUrl (BaseUrl,

48+ SupportsServantReflex,

49+ showBaseUrl)

50+import Web.FormUrlEncoded (FromForm, urlDecodeAsForm)

51+import Web.HttpApiData (ToHttpApiData (..))

4852-------------------------------------------------------------------------------

4953import Servant.API.BasicAuth

5054-------------------------------------------------------------------------------

5155

52−

53−------------------------------------------------------------------------------

56+jsonDecode = undefined

57+-----------------------------------------------------------------------------

5458-- | The result of a request event

5559data ReqResult tag a

5660 = ResponseSuccess tag a XhrResponse

@@ -144,33 +148,39 @@ data QueryPart t = QueryPartParam (Dynamic t (Either Text (Maybe Text)))

144148-------------------------------------------------------------------------------

145149-- The data structure used to build up request information while traversing

146150-- the shape of a servant API

147−data Req t = Req

151+data Req t o = Req

148152 { reqMethod :: Text

149153 , reqPathParts :: [Dynamic t (Either Text Text)]

150154 , qParams :: [(Text, QueryPart t)]

151− , reqBody :: Maybe (Dynamic t (Either Text (BL.ByteString, Text)))

155+ , reqBody :: Maybe (Dynamic t (Either Text (o, Text)))

152156 , headers :: [(Text, Dynamic t (Either Text Text))]

153157 , respHeaders :: XhrResponseHeaders

154158 , authData :: Maybe (Dynamic t (Maybe BasicAuthData))

155159 }

156160

157−defReq :: Req t

161+defReq :: IsXhrPayload o => Req t o

158162defReq = Req "GET" [] [] Nothing [] def Nothing

159163

160−prependToPathParts :: Dynamic t (Either Text Text) -> Req t -> Req t

164+prependToPathParts :: Dynamic t (Either Text Text) -> Req t o -> Req t o

161165prependToPathParts p req =

162166 req { reqPathParts = p : reqPathParts req }

163167

164−addHeader :: (ToHttpApiData a, Reflex t) => Text -> Dynamic t (Either Text a) -> Req t -> Req t

168+addHeader :: (ToHttpApiData a, Reflex t) => Text -> Dynamic t (Either Text a) -> Req t o -> Req t o

165169addHeader name val req = req { headers = (name, (fmap . fmap) (T.decodeUtf8 . toHeader) val) : headers req }

166170

167171

172+-- class ReflexDom'MimeRender a b | b -> a where

173+-- ghcjsMimerender :: IsXhrPayload c => Proxy a -> b -> c

174+

175+-- instance ReflexDom'MimeRender BL.ByteString Blob where

176+-- ghcjsMimerender _ = id

177+

168178reqToReflexRequest

169− :: forall t. Reflex t

170− => Text

171− -> Dynamic t BaseUrl

172− -> Req t

173− -> Dynamic t (Either Text (XhrRequest XhrPayload))

179+ :: forall t o. Reflex t

180+ => Text

181+ -> Dynamic t BaseUrl

182+ -> Req t o

183+ -> Dynamic t (Either Text (XhrRequest (Maybe o)))

174184reqToReflexRequest reqMeth reqHost req =

175185 let t :: Dynamic t [Either Text Text]

176186 t = sequence $ reverse $ reqPathParts req

@@ -223,14 +233,14 @@ reqToReflexRequest reqMeth reqHost req =

223233 fmap (fmap (\rightVal -> (headerName, rightVal))) dynam

224234

225235 mkConfigBody :: Either Text [(Text,Text)]

226− -> (Either Text (BL.ByteString, Text))

227− -> Either Text (XhrRequestConfig XhrPayload)

236+ -> (Either Text (o, Text))

237+ -> Either Text (XhrRequestConfig (Maybe o))

228238 mkConfigBody ehs rb = case (ehs, rb) of

229239 (_, Left e) -> Left e

230240 (Left e, _) -> Left e

231241 (Right hs, Right (bBytes, bCT)) ->

232242 Right $ XhrRequestConfig

233− { _xhrRequestConfig_sendData = bytesToPayload bBytes

243+ { _xhrRequestConfig_sendData = Just bBytes

234244 , _xhrRequestConfig_headers =

235245 Map.insert "Content-Type" bCT (Map.fromList hs)

236246 , _xhrRequestConfig_user = Nothing

@@ -240,7 +250,7 @@ reqToReflexRequest reqMeth reqHost req =

240250 , _xhrRequestConfig_responseHeaders = def

241251 }

242252

243− xhrOpts :: Dynamic t (Either Text (XhrRequestConfig XhrPayload))

253+ xhrOpts :: Dynamic t (Either Text (XhrRequestConfig (Maybe o)))

244254 xhrOpts = case reqBody req of

245255 Nothing -> ffor xhrHeaders $ \case

246256 Left e -> Left e

@@ -248,8 +258,8 @@ reqToReflexRequest reqMeth reqHost req =

248258 , _xhrRequestConfig_user = Nothing

249259 , _xhrRequestConfig_password = Nothing

250260 , _xhrRequestConfig_responseType = Nothing

251− , _xhrRequestConfig_sendData = ""

252261 , _xhrRequestConfig_withCredentials = False

262+ , _xhrRequestConfig_sendData = Nothing

253263 }

254264 Just rBody -> liftA2 mkConfigBody xhrHeaders rBody

255265

@@ -263,7 +273,7 @@ reqToReflexRequest reqMeth reqHost req =

263273 addAuth :: Dynamic t (Either Text (XhrRequestConfig x))

264274 -> Dynamic t (Either Text (XhrRequestConfig x))

265275 addAuth xhr = case authData req of

266− Nothing -> xhr

276+ Nothing -> xhr

267277 Just auth -> liftA2 mkAuth auth xhr

268278

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

@@ -275,17 +285,20 @@ reqToReflexRequest reqMeth reqHost req =

275285displayHttpRequest :: Text -> Text

276286displayHttpRequest httpmethod = "HTTP " <> httpmethod <> " request"

277287

288+instance IsXhrPayload o => IsXhrPayload (Maybe o) where

289+ sendXhrPayload xhr = maybe (sendXhrPayload xhr ()) (sendXhrPayload xhr)

290+

278291-- | This function performs the request

279−performRequests :: forall t m f tag.(SupportsServantReflex t m, Traversable f)

292+performRequests :: forall t o m f tag. (SupportsServantReflex t m, Traversable f, IsXhrPayload o, Show o)

280293 => Text

281− -> Dynamic t (f (Req t))

294+ -> Dynamic t (f (Req t o))

282295 -> Dynamic t BaseUrl

283296 -> ClientOptions

284297 -> Event t tag

285298 -> m (Event t (tag, f (Either Text XhrResponse)))

286299performRequests reqMeth rs reqHost opts trigger = do

287300 let xhrReqs =

288− join $ (\(fxhr :: f (Req t)) -> sequence $

301+ join $ (\(fxhr :: f (Req t o)) -> sequence $

289302 reqToReflexRequest reqMeth reqHost <$> fxhr) <$> rs

290303

291304 -- xhrReqs = fmap snd <$> xhrReqsAndDebugs

@@ -338,17 +351,12 @@ performSomeRequestsAsync' opts newXhr req = performEventAsync $ ffor req $ \hrs

338351 return ()

339352

340353

341−type XhrPayload = T.Text

342−bytesToPayload :: BL.ByteString -> XhrPayload

343−bytesToPayload = T.decodeUtf8 . BL.toStrict

344−

345−

346354performRequestsCT

347355 :: (SupportsServantReflex t m,

348− MimeUnrender ct a, Traversable f)

356+ MimeUnrender ct a, Traversable f, IsXhrPayload o, Show o)

349357 => Proxy ct

350358 -> Text

351− -> Dynamic t (f (Req t))

359+ -> Dynamic t (f (Req t o))

352360 -> Dynamic t BaseUrl

353361 -> ClientOptions

354362 -> Event t tag

@@ -369,9 +377,10 @@ performRequestsCT ct reqMeth reqs reqHost opts trigger = do

369377

370378performRequestsNoBody

371379 :: (SupportsServantReflex t m,

372− Traversable f)

380+ Traversable f,

381+ IsXhrPayload o, Show o)

373382 => Text

374− -> Dynamic t (f (Req t))

383+ -> Dynamic t (f (Req t o))

375384 -> Dynamic t BaseUrl

376385 -> ClientOptions

377386 -> Event t tag

src/Servant/Reflex.hs+42−48

@@ -36,54 +36,49 @@ module Servant.Reflex

3636

3737------------------------------------------------------------------------------

3838import Control.Applicative

39−import Data.Monoid ((<>))

40−import qualified Data.Set as Set

41−import qualified Data.Text.Encoding as E

42−import Data.CaseInsensitive (mk)

39+import Data.CaseInsensitive (mk)

4340import Data.Functor.Identity

44−import Data.Proxy (Proxy (..))

45−import qualified Data.Map as Map

46−import Data.Text (Text)

47−import qualified Data.Text as T

48−import GHC.Exts (Constraint)

49−import GHC.TypeLits (KnownSymbol, symbolVal)

50−import Servant.API ((:<|>)(..),(:>), BasicAuth,

51− BasicAuthData, BuildHeadersTo(..),

52− Capture, contentType, Header,

53− Headers(..), HttpVersion, IsSecure,

54− MimeRender(..),

55− NoContent, QueryFlag, QueryParam,

56− QueryParams, Raw, ReflectMethod(..),

57− RemoteHost, ReqBody,

58− ToHttpApiData(..), Vault, Verb)

59−import qualified Servant.Auth as Auth

60−

61−import Reflex.Dom.Core (Dynamic, Event, Reflex,

62− XhrRequest(..),

63− XhrResponseHeaders(..),

64− XhrResponse(..), attachPromptlyDynWith, constDyn, ffor, fmapMaybe,

65− leftmost, performRequestsAsync,

66− )

41+import qualified Data.Map as Map

42+import Data.Monoid ((<>))

43+import Data.Proxy (Proxy (..))

44+import qualified Data.Set as Set

45+import Data.Text (Text)

46+import qualified Data.Text as T

47+import qualified Data.Text.Encoding as E

48+import GHC.Exts (Constraint)

49+import GHC.TypeLits (KnownSymbol, symbolVal)

50+import Servant.API ((:<|>) (..), (:>), BasicAuth,

51+ BasicAuthData, BuildHeadersTo (..),

52+ Capture, Header, Headers (..),

53+ HttpVersion, IsSecure, MimeRender (..),

54+ NoContent, QueryFlag, QueryParam,

55+ QueryParams, Raw, ReflectMethod (..),

56+ RemoteHost, ReqBody,

57+ ToHttpApiData (..), Vault, Verb,

58+ contentType)

59+import qualified Servant.Auth as Auth

60+

61+import Reflex.Dom.Core (Dynamic, Event, IsXhrPayload, Reflex,

62+ XhrRequest (..), XhrResponse (..),

63+ XhrResponseHeaders (..),

64+ attachPromptlyDynWith, constDyn, ffor,

65+ fmapMaybe, leftmost,

66+ performRequestsAsync)

6767------------------------------------------------------------------------------

68−import Servant.Common.BaseUrl (BaseUrl(..), Scheme(..), baseUrlWidget,

69− showBaseUrl,

70− SupportsServantReflex)

71−import Servant.Common.Req (ClientOptions(..), MimeUnrender(..),

72− defaultClientOptions,

73− Req, ReqResult(..), QParam(..),

74− QueryPart(..), addHeader, authData,

75− defReq, evalResponse, prependToPathParts,

76− -- performRequestCT,

77− performRequestsCT,

78− -- performRequestNoBody,

79− performRequestsNoBody,

80− performSomeRequestsAsync,

81− qParamToQueryPart, reqBody,

82− reqSuccess, reqFailure,

83− reqMethod, respHeaders,

84− response,

85− reqTag,

86− qParams, withCredentials)

68+import Servant.Common.BaseUrl (BaseUrl (..), Scheme (..),

69+ SupportsServantReflex, baseUrlWidget,

70+ showBaseUrl)

71+import Servant.Common.Req (ClientOptions (..), MimeUnrender (..),

72+ QParam (..), QueryPart (..), Req,

73+ ReqResult (..), addHeader, authData,

74+ defReq, defaultClientOptions,

75+ evalResponse, performRequestsCT,

76+ performRequestsNoBody,

77+ performSomeRequestsAsync,

78+ prependToPathParts, qParamToQueryPart,

79+ qParams, reqBody, reqFailure,

80+ reqMethod, reqSuccess, reqTag,

81+ respHeaders, response, withCredentials)

8782

8883

8984-- * Accessing APIs as a Client

@@ -126,7 +121,7 @@ clientWithOpts p q t baseurl = clientWithRoute p q t defReq baseurl

126121-- an internal class, you can just use 'client'.

127122class HasClient t m layout (tag :: *) where

128123 type Client t m layout tag :: *

129− clientWithRoute :: Proxy layout -> Proxy m -> Proxy tag -> Req t -> Dynamic t BaseUrl -> ClientOptions -> Client t m layout tag

124+ clientWithRoute :: IsXhrPayload o => Proxy layout -> Proxy m -> Proxy tag -> Req t o -> Dynamic t BaseUrl -> ClientOptions -> Client t m layout tag

130125

131126

132127instance (HasClient t m a tag, HasClient t m b tag) => HasClient t m (a :<|> b) tag where

@@ -570,4 +565,3 @@ type family HasCookieAuth xs :: Constraint where

570565 HasCookieAuth '[] = CookieAuthNotEnabled

571566

572567class CookieAuthNotEnabled

573−