mirror of
https://github.com/ilyakooo0/servant-reflex.git
synced 2024-10-26 02:11:36 +03:00
Support QueryParams and QueryFlag, add examples
This commit is contained in:
parent
43ad24b744
commit
364ab94d2a
@ -8,5 +8,8 @@ import Servant.API
|
||||
-- | API spec for server, client, and docs
|
||||
type API = "getunit" :> Get '[JSON] ()
|
||||
:<|> "getint" :> Get '[JSON] Int
|
||||
:<|> "sayhi" :> QueryParam "username" String :> Get '[JSON] String
|
||||
:<|> "sayhi" :> QueryParam "username" String
|
||||
:> QueryParams "greetings" String
|
||||
:> QueryFlag "gusto"
|
||||
:> Get '[JSON] String
|
||||
:<|> Raw
|
||||
|
@ -28,28 +28,42 @@ run = do
|
||||
let (getUnit :<|> getInt :<|> sayhi :<|> doRaw) =
|
||||
client api (Proxy :: Proxy m) (constDyn url)
|
||||
|
||||
unitBtn <- button "Get unit"
|
||||
intBtn <- button "Get int"
|
||||
elClass "div" "demo-group" $ do
|
||||
unitBtn <- button "Get unit"
|
||||
intBtn <- button "Get int"
|
||||
|
||||
unitResponse <- getUnit unitBtn
|
||||
intResponse :: Event t (Maybe Int, XhrResponse) <- getInt intBtn
|
||||
unitResponse <- getUnit unitBtn
|
||||
intResponse :: Event t (Maybe Int, XhrResponse) <- getInt intBtn
|
||||
|
||||
score <- foldDyn (+) 0 (fmapMaybe fst intResponse)
|
||||
score <- foldDyn (+) 0 (fmapMaybe fst intResponse)
|
||||
|
||||
r <- holdDyn "Waiting" $
|
||||
r <- holdDyn "Waiting" $
|
||||
leftmost [fmap (showXhrResponse . snd) unitResponse
|
||||
,fmap (showXhrResponse . snd) intResponse
|
||||
]
|
||||
dynText r >> el "br" (return ()) >> text "Total: " >> display score
|
||||
dynText r >> el "br" (return ()) >> text "Total: " >> display score
|
||||
|
||||
el "br" $ return ()
|
||||
text "Name"
|
||||
inp :: Dynamic t String <- fmap value (textInput def)
|
||||
let checkedinp = fmap (\i -> bool (Just i) Nothing (null i)) (current inp)
|
||||
sayhiClicks :: Event t () <- button "Say hi"
|
||||
resp <- fmap fst <$> sayhi checkedinp sayhiClicks
|
||||
el "br" $ return ()
|
||||
dynText =<< holdDyn "No hi yet" (fmapMaybe id resp)
|
||||
elClass "div" "demo-group" $ do
|
||||
|
||||
text "Name"
|
||||
el "br" $ return ()
|
||||
inp :: Dynamic t String <- fmap value (textInput def)
|
||||
let checkedName = fmap (\i -> bool (Just i) Nothing (null i)) (current inp)
|
||||
el "br" $ return ()
|
||||
|
||||
text "Greetings (space-separated)"
|
||||
el "br" $ return ()
|
||||
greetings <- fmap (fmap words . current . value) (textInput def)
|
||||
|
||||
el "br" $ return ()
|
||||
|
||||
gusto <- value <$> checkbox False def
|
||||
|
||||
el "br" $ return ()
|
||||
sayhiClicks :: Event t () <- button "Say hi"
|
||||
|
||||
resp <- fmap fst <$> sayhi checkedName greetings (current gusto) sayhiClicks
|
||||
dynText =<< holdDyn "No hi yet" (fmapMaybe id resp)
|
||||
|
||||
showXhrResponse :: XhrResponse -> String
|
||||
showXhrResponse (XhrResponse stat stattxt rbmay rtmay) =
|
||||
|
@ -1,17 +1,14 @@
|
||||
{-# LANGUAGE DeriveDataTypeable #-}
|
||||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
module Servant.Common.Req where
|
||||
|
||||
-- import Control.Exception
|
||||
-- import Control.Monad
|
||||
-- import Control.Monad.Catch (MonadThrow)
|
||||
-- import Control.Monad.IO.Class
|
||||
-- import Control.Monad.Trans.Except
|
||||
import Control.Applicative (liftA2)
|
||||
import Data.ByteString.Char8 hiding (pack, filter, map, null, elem)
|
||||
import qualified Data.ByteString.Lazy.Char8 as BL
|
||||
import Data.Maybe
|
||||
import qualified Data.Text.Encoding as TE
|
||||
-- import qualified Data.Foldable as F
|
||||
import qualified Data.List as L
|
||||
@ -64,9 +61,13 @@ import Web.HttpApiData
|
||||
|
||||
-- instance Exception ServantError
|
||||
|
||||
data QueryPart t = QueryPartParam (Behavior t [String])
|
||||
| QueryPartFlag (Behavior t Bool)
|
||||
|
||||
data Req t = Req
|
||||
{ reqPathParts :: [Behavior t (Maybe String)]
|
||||
, qParams :: [(String, Behavior t [String])]
|
||||
-- , qParams :: [(String, Behavior t [QueryPart])]
|
||||
, qParams :: [(String, QueryPart t)]
|
||||
, reqBody :: Maybe (ByteString, String)
|
||||
-- , reqAccept :: [MediaType]
|
||||
, headers :: [(String, Behavior t String)]
|
||||
@ -103,22 +104,41 @@ performRequest reqMethod req _ trigger = do
|
||||
let urlParts :: Behavior t (Maybe [String]) = fmap sequence t
|
||||
let urlPath :: Behavior t (Maybe String) = (fmap.fmap) (L.intercalate "/") urlParts
|
||||
|
||||
let oneNamedPair :: String -> [String] -> String
|
||||
oneNamedPair pName ps =
|
||||
L.intercalate "&" $ map (\p -> pName ++ "=" ++ p) ps
|
||||
queryPartString :: (String, QueryPart t) -> Behavior t (Maybe String)
|
||||
queryPartString (pName, qp) = case qp of
|
||||
QueryPartParam ps -> ffor ps $ \pStrings -> -- case null pStrings of
|
||||
if null pStrings
|
||||
then Nothing
|
||||
else Just (L.intercalate "&" (fmap (\p -> pName ++ '=' : p) pStrings))
|
||||
QueryPartFlag fl -> ffor fl $ \case
|
||||
True -> Just pName
|
||||
False -> Nothing
|
||||
|
||||
t' :: [Behavior t String]
|
||||
t' = map (\(pName, pVals) -> fmap (oneNamedPair pName) pVals)
|
||||
(qParams req)
|
||||
|
||||
queryString :: Behavior t String
|
||||
queryString = fmap (L.intercalate "&") (sequence t')
|
||||
|
||||
xhrUrl = (liftA2 . liftA2) (\u q -> u ++ '?' : q) urlPath (fmap Just queryString)
|
||||
queryPartStrings = map queryPartString (qParams req)
|
||||
queryPartStrings' = sequence queryPartStrings :: Behavior t [Maybe String]
|
||||
queryString :: Behavior t (Maybe String ) =
|
||||
ffor queryPartStrings' $ \qs -> Just (L.intercalate "&" (catMaybes qs))
|
||||
xhrUrl = (liftA2 . liftA2) (\p q -> p ++ '?' : q) urlPath queryString
|
||||
xhrReq = (fmap . fmap) (\p -> XhrRequest reqMethod p def) xhrUrl
|
||||
|
||||
performRequestAsync (fmapMaybe id $ tag xhrReq trigger)
|
||||
|
||||
-- let oneNamedPair :: String -> [QueryPart] -> String
|
||||
-- oneNamedPair pName ps =
|
||||
-- L.intercalate "&" $ ffor ps $ \case
|
||||
-- QueryPartParam pval -> pName ++ "=" ++ pval
|
||||
-- QueryPartFlag True -> pName
|
||||
-- QueryPartFlag False -> error "Impossible case"
|
||||
|
||||
-- t' :: [Behavior t String]
|
||||
-- t' = map (\(pName, pVals) -> fmap (oneNamedPair pName) pVals)
|
||||
-- (qParams req)
|
||||
|
||||
-- queryString :: Behavior t String
|
||||
-- queryString = fmap (L.intercalate "&") (sequence t')
|
||||
|
||||
-- xhrUrl = (liftA2 . liftA2) (\u q -> u ++ '?' : q) urlPath (fmap Just queryString)
|
||||
|
||||
-- TODO implement
|
||||
-- => String -> Req -> BaseUrl -> ExceptT ServantError IO [HTTP.Header]
|
||||
-- TODO Proxy probably not needed
|
||||
@ -137,9 +157,9 @@ performRequestCT ct reqMethod req reqHost trigger = do
|
||||
return $ ffor resp $ \xhr ->
|
||||
(hushed (mimeUnrender ct . BL.fromStrict . TE.encodeUtf8)
|
||||
=<< _xhrResponse_responseText xhr, xhr)
|
||||
where hushed :: (x -> Either e y) -> (x -> Maybe y)
|
||||
where hushed :: (x -> Either e y) -> x -> Maybe y
|
||||
hushed f ea = case f ea of
|
||||
Left e -> Nothing
|
||||
Left _ -> Nothing
|
||||
Right a -> Just a
|
||||
|
||||
|
||||
|
@ -245,7 +245,7 @@ instance (KnownSymbol sym, ToHttpApiData a, HasClient t m sublayout, Reflex t)
|
||||
(req {qParams = paramPair : qParams req}) baseurl
|
||||
|
||||
where pname = symbolVal (Proxy :: Proxy sym)
|
||||
p prm = fmap maybeToList $ (fmap . fmap) (unpack . toQueryParam) prm
|
||||
p prm = QueryPartParam $ fmap maybeToList $ (fmap . fmap) (unpack . toQueryParam) prm
|
||||
paramPair = (pname, p mparam)
|
||||
|
||||
-- | If you use a 'QueryParams' in one of your endpoints in your API,
|
||||
@ -287,8 +287,8 @@ instance (KnownSymbol sym, ToHttpApiData a, HasClient t m sublayout, Reflex t)
|
||||
|
||||
where req' = req { qParams = (pname, params') : qParams req }
|
||||
pname = symbolVal (Proxy :: Proxy sym)
|
||||
params' = (fmap . fmap) (unpack . toQueryParam)
|
||||
paramlist :: Behavior t [String]
|
||||
params' = QueryPartParam $ (fmap . fmap) (unpack . toQueryParam)
|
||||
paramlist
|
||||
|
||||
|
||||
-- | If you use a 'QueryFlag' in one of your endpoints in your API,
|
||||
@ -315,21 +315,18 @@ instance (KnownSymbol sym, ToHttpApiData a, HasClient t m sublayout, Reflex t)
|
||||
-- > -- 'getBooksBy True' to only get _already published_ books
|
||||
|
||||
-- TODO Bring back
|
||||
-- instance (KnownSymbol sym, HasClient t m sublayout)
|
||||
-- => HasClient t m (QueryFlag sym :> sublayout) where
|
||||
instance (KnownSymbol sym, HasClient t m sublayout, Reflex t)
|
||||
=> HasClient t m (QueryFlag sym :> sublayout) where
|
||||
|
||||
-- type Client t m (QueryFlag sym :> sublayout) =
|
||||
-- Bool -> Client t m sublayout
|
||||
type Client t m (QueryFlag sym :> sublayout) =
|
||||
Behavior t Bool -> Client t m sublayout
|
||||
|
||||
-- clientWithRoute Proxy req baseurl flag =
|
||||
-- clientWithRoute (Proxy :: Proxy sublayout)
|
||||
-- (if flag
|
||||
-- then appendToQueryString paramname Nothing req
|
||||
-- else req
|
||||
-- )
|
||||
-- baseurl
|
||||
clientWithRoute Proxy q req baseurl flag =
|
||||
clientWithRoute (Proxy :: Proxy sublayout) q req' baseurl
|
||||
|
||||
-- where paramname = cs $ symbolVal (Proxy :: Proxy sym)
|
||||
where req' = req { qParams = thisPair : qParams req }
|
||||
thisPair = (pName, QueryPartFlag flag) :: (String, QueryPart t)
|
||||
pName = symbolVal (Proxy :: Proxy sym)
|
||||
|
||||
|
||||
-- | Pick a 'Method' and specify where the server you want to query is. You get
|
||||
|
@ -6,9 +6,12 @@
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
|
||||
import Data.Aeson
|
||||
import Data.Bool
|
||||
import Data.Char (toUpper)
|
||||
import qualified Data.List as L
|
||||
import Data.Monoid
|
||||
import Data.Proxy
|
||||
import Data.Text
|
||||
import Data.Text hiding (length, null, map, head, toUpper)
|
||||
import GHC.Generics
|
||||
import Snap.Http.Server
|
||||
import Snap.Core
|
||||
@ -42,9 +45,16 @@ data App = App
|
||||
-- Each handler runs in the 'ExceptT ServantErr IO' monad.
|
||||
server :: Server API (Handler App App)
|
||||
server = return () :<|> return 100 :<|> sayhi :<|> serveDirectory "static"
|
||||
where sayhi nm = case nm of
|
||||
Nothing -> return "Sorry, who are you?"
|
||||
Just n -> return $ "Hi, " <> n <> "!"
|
||||
where sayhi nm greetings withGusto = case nm of
|
||||
Nothing -> return ("Sorry, who are you?" :: String)
|
||||
Just n -> do
|
||||
let modifier = bool id (map toUpper) withGusto
|
||||
greetPart
|
||||
| null greetings = "Hi, "
|
||||
| length greetings == 1 = L.head greetings ++ ", "
|
||||
| otherwise = L.intercalate ", " (L.init greetings)
|
||||
++ ", and " ++ L.last greetings ++ ", "
|
||||
return . modifier $ greetPart ++ n
|
||||
|
||||
-- Turn the server into a WAI app. 'serve' is provided by servant,
|
||||
-- more precisely by the Servant.Server module.
|
||||
|
Loading…
Reference in New Issue
Block a user