44acee3 · servant-reflex

git.iko.soy/servant-reflex

on master help sign in

Make functor-dynamic warnings go away - merge req headers

44acee3Greg Hale10 years ago

exec/Example.hs+4−3

compare with master

unifiedsplit

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

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

33 url <- baseUrlWidget

34 el "br" (return ())

35− dynText =<< mapDyn showBaseUrl url

35+ dynText $ showBaseUrl <$> url

36 el "br" (return ())

38 -- Name the computed API client functions

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

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

97showXhrResponse :: XhrResponse -> Text

98−showXhrResponse (XhrResponse stat stattxt rbmay rtmay) =

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

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

100 ,"stattxt: " <> tShow stattxt

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

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

102+ ,"rtext: " <> tShow rtmay

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

103

104

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

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

105tShow = T.pack . show

106tShow = T.pack . show

overrides-ghc.nix+1−2

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

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

5in reflex-platform.ghc.override {

6 overrides = self: super: {

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

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

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

9 };

8 };

10}

overrides.nix+10−5

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

1{ reflex-platform, ... }:

2−let

2+let

3− pkgs = import <nixpkgs> {};

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

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

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

6+ cabal2nixResult = reflex-platform.cabal2nixResult;

8+in

5−in reflex-platform.ghcjs.override {

9+reflex-platform.ghcjs.override {

6− overrides = self: super: {

10+ overrides = self: super: {

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

7 };

12 };

13}

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

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

15 , showBaseUrl

16) where

18+import Control.Monad (join)

18−import Data.Monoid

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

19import Data.Text (Text)

20import Data.Text (Text)

20import qualified Data.Text as T

21import qualified Data.Text as T

21import GHC.Generics

22import GHC.Generics

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

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

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

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

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

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

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

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

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

64− 0 -> pathWidget

65+ 0 -> pathWidget

65− 1 -> fullUrlWidget

66+ 1 -> fullUrlWidget

66− _ -> error "Surprising value"

67+ _ -> error "Surprising value"

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

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

68 where pathWidget :: m (Dynamic t BaseUrl)

69 where pathWidget :: m (Dynamic t BaseUrl)

69 pathWidget = do

70 pathWidget = do

70 text "Url base path"

71 text "Url base path"

71 t <- textInput (def {_textInputConfig_attributes =

72 t <- textInput (def {_textInputConfig_attributes =

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

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

73− mapDyn BasePath (value t)

74+ return $ BasePath <$> value t

74 fullUrlWidget :: m (Dynamic t BaseUrl)

75 fullUrlWidget :: m (Dynamic t BaseUrl)

75 fullUrlWidget = do

76 fullUrlWidget = do

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

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

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

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

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

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

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

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

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

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

83+ return $ BaseFullUrl <$> value schm <*> value srv <*> port <*> 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

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

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

18import Data.Text (Text)

19import qualified Data.Text as T

20import qualified Data.Text.Encoding as TE

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

22−import qualified Data.Text.Lazy as LT

23import Reflex

21import Reflex

24import Reflex.Dom

22import Reflex.Dom

25import Servant.Common.BaseUrl

23import Servant.Common.BaseUrl

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

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

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

70 }

68 }

72−defReq :: Reflex t => Req t

70+defReq :: Req t

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

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

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

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

76prependToPathParts p req =

74prependToPathParts p req =

77 req { reqPathParts = p : reqPathParts req }

75 req { reqPathParts = p : reqPathParts req }

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

77addHeader :: (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 }

83-- * performing requests

81-- * performing requests

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

144

142

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

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

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

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

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

145+ -> Either Text (XhrRequestConfig XhrPayload)

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

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

149 (_, Left e) -> Left e

147 (_, Left e) -> Left e

150 (Left e, _) -> Left e

148 (Left e, _) -> Left e

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

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

152 Right $ XhrRequestConfig

150 Right $ XhrRequestConfig

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

151+ { _xhrRequestConfig_sendData = bytesToPayload bBytes

154 , _xhrRequestConfig_headers =

152 , _xhrRequestConfig_headers =

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

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

154+ , _xhrRequestConfig_user = Nothing

156 , _xhrRequestConfig_password = Nothing

155 , _xhrRequestConfig_password = Nothing

157 , _xhrRequestConfig_responseType = Nothing

156 , _xhrRequestConfig_responseType = Nothing

158 , _xhrRequestConfig_withCredentials = False

157 , _xhrRequestConfig_withCredentials = False

159 , _xhrRequestConfig_responseHeaders = def

158 , _xhrRequestConfig_responseHeaders = def

160 }

159 }

161

160

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

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

163 xhrOpts = case reqBody req of

162 xhrOpts = case reqBody req of

164 Nothing -> ffor xhrHeaders $ \case

163 Nothing -> ffor xhrHeaders $ \case

165 Left e -> Left e

164 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+ }

167 Just rBody -> liftA2 mkConfigBody xhrHeaders rBody

172 Just rBody -> liftA2 mkConfigBody xhrHeaders rBody

168

173

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

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

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

181

186

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

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

183

188

184− let reqs = tagDyn xhrReq trigger

189+ let reqs = tagPromptlyDyn xhrReq trigger

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

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

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

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

187

192

188−#ifndef ghcjs_HOST_OS

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

190−#else

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

193+ resps <- performRequestAsync okReqs

192−#endif

193

194

194 return (resps, badReqs)

195 return (resps, badReqs)

195

196

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

196

206

197-- TODO implement

207-- TODO implement

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

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

src/Servant/Reflex.hs+4−4

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

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

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

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

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

54+client :: (HasClient t m layout)

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

56client p q baseurl = clientWithRoute p q defReq baseurl

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

80-- -> Event t ()

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

82-- > 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)

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

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

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

183 q

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

185 baseurl

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

186

187

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

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

188-- functions.

189-- functions.

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

337 <> _xhrRequest_url jx})

338 <> _xhrRequest_url jx})

338 xhrs

339 xhrs

339 (showBaseUrl <$> baseurl)

340 (showBaseUrl <$> baseurl)

340− reqs = tagDyn xhrs' triggers

341+ reqs = tagPromptlyDyn xhrs' triggers

341 okReq = fmapMaybe hush reqs

342 okReq = fmapMaybe hush reqs

342 badReq = fmapMaybe tattle reqs

343 badReq = fmapMaybe tattle reqs

343 resps <- performRequestAsync okReq

344 resps <- performRequestAsync okReq

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

382 where req' = req { reqBody = bodyBytesCT }

383 where req' = req { reqBody = bodyBytesCT }

383 ctProxy = Proxy :: Proxy ct

384 ctProxy = Proxy :: Proxy ct

384 ctString = T.pack $ show $ contentType ctProxy

385 ctString = T.pack $ show $ contentType ctProxy

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

386 bodyBytesCT = Just $ (fmap . fmap)

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

388 body