Allow arbitrary JSON values (not only arrays and objects)
And added tests for QueryFlag.
This commit is contained in:
parent
c2be4f3377
commit
16dbf9b188
3 changed files with 30 additions and 3 deletions
|
@ -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
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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) =
|
||||||
|
|
Loading…
Add table
Reference in a new issue