From 364ab94d2a873bca5428f7585c9c468fdff30c24 Mon Sep 17 00:00:00 2001 From: Greg Hale Date: Sun, 6 Mar 2016 23:28:26 -0500 Subject: [PATCH] Support QueryParams and QueryFlag, add examples --- exec/API.hs | 5 +++- exec/Example.hs | 44 +++++++++++++++++++---------- src/Servant/Common/Req.hs | 58 ++++++++++++++++++++++++++------------- src/Servant/Reflex.hs | 27 ++++++++---------- testserver/Main.hs | 18 +++++++++--- 5 files changed, 98 insertions(+), 54 deletions(-) diff --git a/exec/API.hs b/exec/API.hs index d321940..f35e158 100644 --- a/exec/API.hs +++ b/exec/API.hs @@ -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 diff --git a/exec/Example.hs b/exec/Example.hs index 8fd9156..e006ecb 100644 --- a/exec/Example.hs +++ b/exec/Example.hs @@ -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) = diff --git a/src/Servant/Common/Req.hs b/src/Servant/Common/Req.hs index 08a6cb6..b1169a3 100644 --- a/src/Servant/Common/Req.hs +++ b/src/Servant/Common/Req.hs @@ -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 diff --git a/src/Servant/Reflex.hs b/src/Servant/Reflex.hs index 2003295..1b712d6 100644 --- a/src/Servant/Reflex.hs +++ b/src/Servant/Reflex.hs @@ -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 diff --git a/testserver/Main.hs b/testserver/Main.hs index e48a65e..448410f 100644 --- a/testserver/Main.hs +++ b/testserver/Main.hs @@ -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.