88b358a · typeable/servant-reflex

git.iko.soy/typeable/servant-reflex

Handle ReqBody requests and add ReqBody example

commit88b358a6d45e9254b47510df4f912d313266370b authorGreg Hale <imalsogreg@gmail.com> dateTue 8 Mar 2016, 13:47 (11 years ago) parent3137f42

6 files changed+42−22

compare with master

unifiedsplit

exec/API.hs+3−1 exec/Example.hs+10−1 servant-reflex.cabal+1−1 src/Servant/Common/Req.hs+18−12 src/Servant/Reflex.hs+7−5 testserver/Main.hs+3−2

exec/API.hs+3−1

@@ -8,8 +8,10 @@ import Servant.API

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

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

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

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

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

1212 :> QueryParams "greetings" String

1313 :> QueryFlag "gusto"

1414 :> Get '[JSON] String

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

16+ :> Post '[JSON] Double

1517 :<|> Raw

exec/Example.hs+10−1

@@ -9,6 +9,7 @@ import Servant.API

99import Servant.Reflex

1010import API

1111import Data.Proxy

12+import Text.Read (readMaybe)

1213import Reflex.Dom

1314

1415api :: Proxy API

@@ -25,7 +26,7 @@ run :: forall t m. MonadWidget t m => m ()

2526run = do

2627

2728 -- Name the computed API client functions

28− let (getUnit :<|> getInt :<|> sayhi :<|> doRaw) =

29+ let (getUnit :<|> getInt :<|> sayhi :<|> dbl :<|> doRaw) =

2930 client api (Proxy :: Proxy m) (constDyn url)

3031

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

@@ -65,6 +66,14 @@ run = do

6566 resp <- fmap fst <$> sayhi checkedName greetings (current gusto) sayhiClicks

6667 dynText =<< holdDyn "No hi yet" (fmapMaybe id resp)

6768

69+ elClass "div" "demo-group" $ do

70+ text "A Double to double"

71+ el "br" $ return ()

72+ dblinp <- value <$> textInput def

73+ dblBtn <- button "Double it"

74+ dblResp :: Event t (Maybe Double) <- fmap fst <$> dbl (fmap readMaybe $ current dblinp) dblBtn

75+ display =<< holdDyn "No number yet" (fmap show $ fmapMaybe id dblResp)

76+

6877showXhrResponse :: XhrResponse -> String

6978showXhrResponse (XhrResponse stat stattxt rbmay rtmay) =

7079 unlines ["stat: " ++ show stat

servant-reflex.cabal+1−1

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

4848 ghc-options: -threaded -Wall -fwarn-tabs -funbox-strict-fields -O2

4949

5050executable example

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

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

5252 default-language: Haskell2010

5353 main-is: Example.hs

5454 other-modules: API

src/Servant/Common/Req.hs+18−12

@@ -67,15 +67,16 @@ data QueryPart t = QueryPartParam (Behavior t [String])

6767 | QueryPartFlag (Behavior t Bool)

6868

6969data Req t = Req

70− { reqPathParts :: [Behavior t (Maybe String)]

70+ { reqMethod :: String

71+ , reqPathParts :: [Behavior t (Maybe String)]

7172 , qParams :: [(String, QueryPart t)]

72− , reqBody :: Behavior t (Maybe (BL.ByteString, String))

73+ , reqBody :: Maybe (Behavior t (Maybe (BL.ByteString, String)))

7374 -- , reqAccept :: [MediaType] -- TODO ?

7475 , headers :: [(String, Behavior t String)]

7576 }

7677

7778defReq :: Reflex t => Req t

78−defReq = Req [] [] (constant Nothing) []

79+defReq = Req "GET" [] [] Nothing []

7980

8081prependToPathParts :: Reflex t => Behavior t (Maybe String) -> Req t -> Req t

8182prependToPathParts p req =

@@ -117,22 +118,27 @@ performRequest reqMethod req _ trigger = do

117118

118119 queryPartStrings = map queryPartString (qParams req)

119120 queryPartStrings' = sequence queryPartStrings :: Behavior t [Maybe String]

120− queryString :: Behavior t (Maybe String ) =

121+ queryString :: Behavior t (Maybe String) =

121122 ffor queryPartStrings' $ \qs -> Just (L.intercalate "&" (catMaybes qs))

122− xhrUrl = (liftA2 . liftA2) (\p q -> p ++ '?' : q) urlPath queryString

123+ xhrUrl = (liftA2 . liftA2) (\p q -> if null q then p else p ++ '?' : q) urlPath queryString

123124

124125 xhrHeaders :: Behavior t [(String, String)]

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

126127

127128

128− mkConfig hs rb = case rb of

129− Nothing -> def { _xhrRequestConfig_headers = Map.fromList hs }

130− (Just (bBytes, bCT)) -> def { _xhrRequestConfig_sendData = Just (BL.unpack bBytes)

131− , _xhrRequestConfig_headers =

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

129+ mkConfigBody :: [(String,String)] -> (Maybe (BL.ByteString, String)) -> Maybe XhrRequestConfig

130+ mkConfigBody hs rb = case rb of

131+ Nothing -> Nothing

132+ (Just (bBytes, bCT)) ->

133+ Just $ def { _xhrRequestConfig_sendData = Just (BL.unpack bBytes)

134+ , _xhrRequestConfig_headers =

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

133136

134− xhrOpts = liftA2 mkConfig xhrHeaders (reqBody req)

135− xhrReq = (fmap . fmap) (\p -> XhrRequest reqMethod p def) xhrUrl

137+ xhrOpts :: Behavior t (Maybe XhrRequestConfig)

138+ xhrOpts = case reqBody req of

139+ Nothing -> fmap (\h -> Just $ def { _xhrRequestConfig_headers = Map.fromList h }) xhrHeaders

140+ Just rBody -> liftA2 mkConfigBody xhrHeaders rBody

141+ xhrReq = (liftA2 . liftA2) (\p opt -> XhrRequest reqMethod p opt) xhrUrl xhrOpts

136142

137143 performRequestAsync (fmapMaybe id $ tag xhrReq trigger)

138144

src/Servant/Reflex.hs+7−5

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

111111 -- TODO how to access input types here?

112112 -- ExceptT ServantError IO a

113113 clientWithRoute Proxy q req baseurl =

114− performRequestCT (Proxy :: Proxy ct) method req baseurl

114+ performRequestCT (Proxy :: Proxy ct) method req' baseurl

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

116+ req' = req { reqMethod = method }

116117

117118-- -- TODO Overlapping error??

118119-- -- VERB (No content) --

@@ -374,10 +375,11 @@ instance (MimeRender ct a, HasClient t m sublayout, Reflex t)

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

375376 where req' = req { reqBody = bodyBytesCT }

376377 ctProxy = Proxy :: Proxy ct

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

378− bodyBytesCT = (fmap . fmap)

379− (\b -> (mimeRender ctProxy b, ctString))

380− body

378+ ctString = show $ contentType ctProxy

379+ --ctString = BS.unpack . CI.original . M.mainType $ contentType ctProxy

380+ bodyBytesCT = Just $ (fmap . fmap)

381+ (\b -> (mimeRender ctProxy b, ctString))

382+ body

381383

382384-- | Make the querying function append @path@ to the request path.

383385instance (KnownSymbol path, HasClient t m sublayout, Reflex t) => HasClient t m (path :> sublayout) where

testserver/Main.hs+3−2

@@ -44,7 +44,7 @@ data App = App

4444--

4545-- Each handler runs in the 'ExceptT ServantErr IO' monad.

4646server :: Server API (Handler App App)

47−server = return () :<|> return 100 :<|> sayhi :<|> serveDirectory "static"

47+server = return () :<|> return 100 :<|> sayhi :<|> dbl :<|> serveDirectory "static"

4848 where sayhi nm greetings withGusto = case nm of

4949 Nothing -> return ("Sorry, who are you?" :: String)

5050 Just n -> do

@@ -55,6 +55,7 @@ server = return () :<|> return 100 :<|> sayhi :<|> serveDirectory "static"

5555 | otherwise = L.intercalate ", " (L.init greetings)

5656 ++ ", and " ++ L.last greetings ++ ", "

5757 return . modifier $ greetPart ++ n

58+ dbl x = return $ x * 2

5859

5960-- Turn the server into a WAI app. 'serve' is provided by servant,

6061-- more precisely by the Servant.Server module.

@@ -64,7 +65,7 @@ test = serve testApi server

6465initApp :: SnapletInit App App

6566initApp = makeSnaplet "myapp" "example" Nothing $ do

6667 addRoutes [("", applicationToSnap test)

67− ,("", serveDirectory "static")

68+-- ,("", serveDirectory "static")

6869 ]

6970 return App

7071