Support QueryParams and QueryFlag, add examples

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

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

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
 
 

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

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.