Allow arbitrary JSON values (not only arrays and objects)

And added tests for QueryFlag.
This commit is contained in:
Sönke Hahn 2014-10-31 20:29:00 +08:00
parent c2be4f3377
commit 16dbf9b188
3 changed files with 30 additions and 3 deletions

View file

@ -35,6 +35,7 @@ library
base >=4.7 && <5 base >=4.7 && <5
, either , either
, aeson , aeson
, attoparsec
, bytestring , bytestring
, exceptions , exceptions
, string-conversions , string-conversions

View file

@ -1,3 +1,4 @@
{-# LANGUAGE ScopedTypeVariables #-}
module Servant.Utils.Client where module Servant.Utils.Client where
import Control.Applicative import Control.Applicative
@ -6,6 +7,10 @@ import Control.Monad
import Control.Monad.IO.Class import Control.Monad.IO.Class
import Control.Monad.Trans.Either import Control.Monad.Trans.Either
import Data.Aeson import Data.Aeson
import Data.Aeson.Parser
import Data.Aeson.Types
import Data.Attoparsec.ByteString
import Data.ByteString.Lazy
import Data.String.Conversions import Data.String.Conversions
import Network.HTTP.Types import Network.HTTP.Types
import Network.URI import Network.URI
@ -32,8 +37,10 @@ performRequest method req wantedStatus host = do
let status = Client.responseStatus response let status = Client.responseStatus response
when (statusCode status /= wantedStatus) $ when (statusCode status /= wantedStatus) $
left (requestString ++ " failed with status: " ++ showStatus status) left (requestString ++ " failed with status: " ++ showStatus status)
result <- maybe (left (requestString ++ " returned invalid json")) return $ result <- either
decode' (Client.responseBody response) (\ message -> left (requestString ++ " returned invalid json: " ++ message))
return
(decodeLenient (Client.responseBody response))
return result return result
where where
requestString = "HTTP " ++ cs method ++ " request" requestString = "HTTP " ++ cs method ++ " request"
@ -46,3 +53,10 @@ catchStatusCodeException action = catch (Right <$> action) $
Client.StatusCodeException status _ _ -> Client.StatusCodeException status _ _ ->
return $ Left status return $ Left status
e -> throwIO e e -> throwIO e
-- | Like 'Data.Aeson.decode' but allows all JSON values instead of just
-- objects and arrays.
decodeLenient :: FromJSON a => ByteString -> Either String a
decodeLenient input = do
v :: Value <- parseOnly (Data.Aeson.Parser.value <* endOfInput) (cs input)
parseEither parseJSON v

View file

@ -8,12 +8,14 @@ module Servant.ClientSpec where
import Control.Concurrent import Control.Concurrent
import Control.Exception import Control.Exception
import Control.Monad.Trans.Either import Control.Monad.Trans.Either
import Data.Foldable
import Data.Proxy import Data.Proxy
import Data.Typeable import Data.Typeable
import Network.Socket import Network.Socket
import Network.URI import Network.URI
import Network.Wai import Network.Wai
import Network.Wai.Handler.Warp import Network.Wai.Handler.Warp
import Prelude hiding (mapM_)
import Test.Hspec import Test.Hspec
import Servant.API import Servant.API
@ -28,6 +30,7 @@ type Api =
:<|> "body" :> ReqBody Person :> Post Person :<|> "body" :> ReqBody Person :> Post Person
:<|> "param" :> QueryParam "name" String :> Get Person :<|> "param" :> QueryParam "name" String :> Get Person
:<|> "params" :> QueryParams "names" String :> Get [Person] :<|> "params" :> QueryParams "names" String :> Get [Person]
:<|> "flag" :> QueryFlag "flag" :> Get Bool
api :: Proxy Api api :: Proxy Api
api = Proxy api = Proxy
@ -41,6 +44,7 @@ server = serve api (
Just name -> left (400, name ++ " not found") Just name -> left (400, name ++ " not found")
Nothing -> left (400, "missing parameter")) Nothing -> left (400, "missing parameter"))
:<|> (\ names -> return (zipWith Person names [0..])) :<|> (\ names -> return (zipWith Person names [0..]))
:<|> return
) )
withServer :: (URIAuth -> IO a) -> IO a withServer :: (URIAuth -> IO a) -> IO a
@ -51,11 +55,13 @@ getCapture :: String -> URIAuth -> EitherT String IO Person
getBody :: Person -> URIAuth -> EitherT String IO Person getBody :: Person -> URIAuth -> EitherT String IO Person
getQueryParam :: Maybe String -> URIAuth -> EitherT String IO Person getQueryParam :: Maybe String -> URIAuth -> EitherT String IO Person
getQueryParams :: [String] -> URIAuth -> EitherT String IO [Person] getQueryParams :: [String] -> URIAuth -> EitherT String IO [Person]
getQueryFlag :: Bool -> URIAuth -> EitherT String IO Bool
( getGet ( getGet
:<|> getCapture :<|> getCapture
:<|> getBody :<|> getBody
:<|> getQueryParam :<|> getQueryParam
:<|> getQueryParams) :<|> getQueryParams
:<|> getQueryFlag)
= client api = client api
spec :: Spec spec :: Spec
@ -80,6 +86,12 @@ spec = do
runEitherT (getQueryParams ["alice", "bob"] host) runEitherT (getQueryParams ["alice", "bob"] host)
`shouldReturn` Right [Person "alice" 0, Person "bob" 1] `shouldReturn` Right [Person "alice" 0, Person "bob" 1]
context "Servant.API.QueryParam.QueryFlag" $
forM_ [False, True] $ \ flag ->
it (show flag) $ withServer $ \ host -> do
runEitherT (getQueryFlag flag host) `shouldReturn` Right flag
context "client correctly handles error status codes" $ do context "client correctly handles error status codes" $ do
let test :: WrappedApi -> Spec let test :: WrappedApi -> Spec
test (WrappedApi api) = test (WrappedApi api) =