44acee3 · servant-reflex

git.iko.soy/servant-reflex

Make functor-dynamic warnings go away - merge req headers

commit44acee362b7042730ca66939bf1dc90a26c497d1 authorGreg Hale <imalsogreg@gmail.com> dateMon 29 Aug 2016, 18:05 (10 years ago) parentd7614ff

6 files changed+53−42

compare with master

unifiedsplit

exec/Example.hs+4−3 overrides-ghc.nix+1−2 overrides.nix+10−5 src/Servant/Common/BaseUrl.hs+9−13 src/Servant/Common/Req.hs+25−15 src/Servant/Reflex.hs+4−4

exec/Example.hs+4−3

@@ -32,7 +32,7 @@ run = do

3232 -- (alternatively we could just `let url = constDyn (BasePath "/")`)

3333 url <- baseUrlWidget

3434 el "br" (return ())

35− dynText =<< mapDyn showBaseUrl url

35+ dynText $ showBaseUrl <$> url

3636 el "br" (return ())

3737

3838 -- Name the computed API client functions

@@ -95,11 +95,12 @@ run = do

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

9696

9797showXhrResponse :: XhrResponse -> Text

98−showXhrResponse (XhrResponse stat stattxt rbmay rtmay) =

98+showXhrResponse (XhrResponse stat stattxt rbmay rtmay respHeaders) =

9999 T.unlines ["stat: " <> tShow stat

100100 ,"stattxt: " <> tShow stattxt

101101 ,"resp: " <> maybe "" showRB rbmay

102− ,"rtext: " <> tShow rtmay]

102+ ,"rtext: " <> tShow rtmay

103+ ,"rHeaders: " <> tShow respHeaders]

103104

104105tShow :: Show a => a -> Text

105106tShow = T.pack . show

overrides-ghc.nix+1−2

@@ -4,7 +4,6 @@ let

44 reflex-platform = import deps/reflex-platform {};

55in reflex-platform.ghc.override {

66 overrides = self: super: {

7− reflex-dom-contrib = pkgs.haskell.lib.dontCheck (self.callPackage deps/reflex-dom-contrib {});

8− servant = pkgs.haskell.lib.dontCheck (self.callPackage (reflex-platform.cabal2nixResult deps/servant/servant) {});

7+ reflex-dom = pkgs.haskell.lib.dontCheck (self.callPackage deps/reflex-dom {});

98 };

109}

overrides.nix+10−5

@@ -1,8 +1,13 @@

11{ reflex-platform, ... }:

2−let

3− pkgs = import <nixpkgs> {};

4− reflex-platform = import deps/reflex-platform {};

5−in reflex-platform.ghcjs.override {

6− overrides = self: super: {

2+let

4+ nixpkgs = (import <nixpkgs> {});

5+ dontCheck = nixpkgs.pkgs.haskell.lib.dontCheck;

6+ cabal2nixResult = reflex-platform.cabal2nixResult;

8+in

9+reflex-platform.ghcjs.override {

10+ overrides = self: super: {

11+ reflex-dom = dontCheck (self.callPackage deps/reflex-dom {});

712 };

813}

src/Servant/Common/BaseUrl.hs+9−13

@@ -15,7 +15,8 @@ module Servant.Common.BaseUrl (

1515 , showBaseUrl

1616) where

1717

18−import Data.Monoid

18+import Control.Monad (join)

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

1920import Data.Text (Text)

2021import qualified Data.Text as T

2122import GHC.Generics

@@ -60,17 +61,17 @@ showBaseUrl (BaseFullUrl urlscheme host port path) =

6061baseUrlWidget :: forall t m .MonadWidget t m => m (Dynamic t BaseUrl)

6162baseUrlWidget = elClass "div" "base-url" $ do

6263 urlWidget <- dropdown (0 :: Int) (constDyn $ 0 =: "BasePath" <> 1 =: "BaseUrlFull") def

63− bUrlWidget <- forDyn (value urlWidget) $ \i -> case i of

64− 0 -> pathWidget

65− 1 -> fullUrlWidget

66− _ -> error "Surprising value"

67− joinDyn <$> widgetHold pathWidget (updated bUrlWidget)

64+ let bUrlWidget = ffor (value urlWidget) $ \i -> case i of

65+ 0 -> pathWidget

66+ 1 -> fullUrlWidget

67+ _ -> error "Surprising value"

68+ join <$> widgetHold pathWidget (updated bUrlWidget)

6869 where pathWidget :: m (Dynamic t BaseUrl)

6970 pathWidget = do

7071 text "Url base path"

7172 t <- textInput (def {_textInputConfig_attributes =

7273 constDyn ("placeholder" =: "/a/b")})

73− mapDyn BasePath (value t)

74+ return $ BasePath <$> value t

7475 fullUrlWidget :: m (Dynamic t BaseUrl)

7576 fullUrlWidget = do

7677 schm <- dropdown Https (constDyn $ Https =: "https" <> Http =: "http") def

@@ -79,9 +80,4 @@ baseUrlWidget = elClass "div" "base-url" $ do

7980 prt <- textInput def { _textInputConfig_attributes = constDyn $ "placeholder" =: "80"}

8081 port :: Dynamic t Int <- holdDyn 80 (fmapMaybe (readMaybe . T.unpack) $ updated (value prt))

8182 path <- textInput def { _textInputConfig_attributes = constDyn $ "placeholder" =: "a/b" }

82− BaseFullUrl `mapDyn` value schm `myApDyn` value srv `myApDyn` port `myApDyn` value path

83−

84−myApDyn :: MonadWidget t m => m (Dynamic t (a -> b)) -> Dynamic t a -> m (Dynamic t b)

85−myApDyn f' a = do

86− f <- f'

87− combineDyn ($) f a

83+ return $ BaseFullUrl <$> value schm <*> value srv <*> port <*> value path

src/Servant/Common/Req.hs+25−15

@@ -18,8 +18,6 @@ import Data.Proxy (Proxy(..))

1818import Data.Text (Text)

1919import qualified Data.Text as T

2020import qualified Data.Text.Encoding as TE

21−import qualified Data.Text.Lazy.Encoding as LTE

22−import qualified Data.Text.Lazy as LT

2321import Reflex

2422import Reflex.Dom

2523import Servant.Common.BaseUrl

@@ -69,15 +67,15 @@ data Req t = Req

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

7068 }

7169

72−defReq :: Reflex t => Req t

70+defReq :: Req t

7371defReq = Req "GET" [] [] Nothing [] Nothing

7472

75−prependToPathParts :: Reflex t => Dynamic t (Either Text Text) -> Req t -> Req t

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

7674prependToPathParts p req =

7775 req { reqPathParts = p : reqPathParts req }

7876

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

80−addHeader name val req = req { headers = (name, (fmap . fmap) toHeader val) : headers req }

78+addHeader name val req = req { headers = (name, (fmap . fmap) (TE.decodeUtf8 . toHeader) val) : headers req }

8179

8280

8381-- * performing requests

@@ -144,26 +142,33 @@ performRequest reqMeth req reqHost trigger = do

144142

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

146144 -> (Either Text (BL.ByteString, Text))

147− -> Either Text (XhrRequestConfig LT.Text)

145+ -> Either Text (XhrRequestConfig XhrPayload)

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

149147 (_, Left e) -> Left e

150148 (Left e, _) -> Left e

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

152150 Right $ XhrRequestConfig

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

151+ { _xhrRequestConfig_sendData = bytesToPayload bBytes

154152 , _xhrRequestConfig_headers =

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

154+ , _xhrRequestConfig_user = Nothing

156155 , _xhrRequestConfig_password = Nothing

157156 , _xhrRequestConfig_responseType = Nothing

158157 , _xhrRequestConfig_withCredentials = False

159158 , _xhrRequestConfig_responseHeaders = def

160159 }

161160

162− xhrOpts :: Dynamic t (Either Text (XhrRequestConfig LT.Text))

161+ xhrOpts :: Dynamic t (Either Text (XhrRequestConfig XhrPayload))

163162 xhrOpts = case reqBody req of

164163 Nothing -> ffor xhrHeaders $ \case

165164 Left e -> Left e

166− Right hs -> Right $ def { _xhrRequestConfig_headers = Map.fromList hs }

165+ Right hs -> Right $ def { _xhrRequestConfig_headers = Map.fromList hs

166+ , _xhrRequestConfig_user = Nothing

167+ , _xhrRequestConfig_password = Nothing

168+ , _xhrRequestConfig_responseType = Nothing

169+ , _xhrRequestConfig_sendData = ""

170+ , _xhrRequestConfig_withCredentials = False

171+ }

167172 Just rBody -> liftA2 mkConfigBody xhrHeaders rBody

168173

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

@@ -181,18 +186,23 @@ performRequest reqMeth req reqHost trigger = do

181186

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

183188

184− let reqs = tagDyn xhrReq trigger

189+ let reqs = tagPromptlyDyn xhrReq trigger

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

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

187192

188−#ifndef ghcjs_HOST_OS

189− resps <- performRequestAsync (fmap LT.toStrict <$> okReqs)

190−#else

191− resps <- performRequestAsync (fmap LT.unpack <$> okReqs)

192−#endif

193+ resps <- performRequestAsync okReqs

193194

194195 return (resps, badReqs)

195196

197+#ifdef ghcjs_HOST_OS

198+type XhrPayload = String

199+bytesToPayload :: BL.ByteString -> XhrPayload

200+bytesToPayload = BL.unpack

201+#else

202+type XhrPayload = T.Text

203+bytesToPayload :: BL.ByteString -> XhrPayload

204+bytesToPayload = T.pack . BL.unpack

205+#endif

196206

197207-- TODO implement

198208-- => String -> Req -> BaseUrl -> ExceptT ServantError IO [HTTP.Header]

src/Servant/Reflex.hs+4−4

@@ -51,7 +51,7 @@ import Reflex.Dom

5151-- -> m (Event t (Either XhrError (Book,Book)))

5252-- > (getAllBooks :<|> postNewBook) = client myApi host

5353-- > where host = constDyn $ BaseUrl Http "localhost" 8080

54−client :: (HasClient t m layout, MonadWidget t m)

54+client :: (HasClient t m layout)

5555 => Proxy layout -> Proxy m -> Dynamic t BaseUrl -> Client t m layout

5656client p q baseurl = clientWithRoute p q defReq baseurl

5757

@@ -80,7 +80,7 @@ instance (HasClient t m a, HasClient t m b) => HasClient t m (a :<|> b) where

8080-- -> Event t ()

8181-- -> m (Event t (Either XhrError (Text, Book)))

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

83−instance (MonadWidget t m, KnownSymbol capture, ToHttpApiData a, HasClient t m sublayout)

83+instance (MonadWidget t m, ToHttpApiData a, HasClient t m sublayout)

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

8585

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

@@ -183,6 +183,7 @@ instance (KnownSymbol sym, ToHttpApiData a,

183183 q

184184 (Servant.Common.Req.addHeader hname eVal req)

185185 baseurl

186+ where hname = T.pack $ symbolVal (Proxy :: Proxy sym)

186187

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

188189-- functions.

@@ -337,7 +338,7 @@ instance (MonadWidget t m) => HasClient t m Raw where

337338 <> _xhrRequest_url jx})

338339 xhrs

339340 (showBaseUrl <$> baseurl)

340− reqs = tagDyn xhrs' triggers

341+ reqs = tagPromptlyDyn xhrs' triggers

341342 okReq = fmapMaybe hush reqs

342343 badReq = fmapMaybe tattle reqs

343344 resps <- performRequestAsync okReq

@@ -382,7 +383,6 @@ instance (MimeRender ct a, HasClient t m sublayout, Reflex t)

382383 where req' = req { reqBody = bodyBytesCT }

383384 ctProxy = Proxy :: Proxy ct

384385 ctString = T.pack $ show $ contentType ctProxy

385− --ctString = decodeUtf8 . CI.original . M.mainType $ contentType ctProxy

386386 bodyBytesCT = Just $ (fmap . fmap)

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

388388 body