git.iko.soy/servant
on master help sign in
Allow arbitrary JSON values (not only arrays and objects)
16dbf9bSönke Hahn
servant.cabal+1
compare with master
unifiedsplit
@@ -35,6 +35,7 @@ library
35 base >=4.7 && <5
35 base >=4.7 && <5
36 , either
36 , either
37 , aeson
37 , aeson
38+ , attoparsec
38 , bytestring
39 , bytestring
39 , exceptions
40 , exceptions
40 , string-conversions
41 , string-conversions
src/Servant/Utils/Client.hs+16−2
@@ -1,3 +1,4 @@
1+{-# LANGUAGE ScopedTypeVariables #-}
1module Servant.Utils.Client where
2module Servant.Utils.Client where
2
3
3import Control.Applicative
4import Control.Applicative
@@ -6,6 +7,10 @@ import Control.Monad
6import Control.Monad.IO.Class
7import Control.Monad.IO.Class
7import Control.Monad.Trans.Either
8import Control.Monad.Trans.Either
8import Data.Aeson
9import Data.Aeson
10+import Data.Aeson.Parser
11+import Data.Aeson.Types
12+import Data.Attoparsec.ByteString
13+import Data.ByteString.Lazy
9import Data.String.Conversions
14import Data.String.Conversions
10import Network.HTTP.Types
15import Network.HTTP.Types
11import Network.URI
16import Network.URI
@@ -32,8 +37,10 @@ performRequest method req wantedStatus host = do
32 let status = Client.responseStatus response
37 let status = Client.responseStatus response
33 when (statusCode status /= wantedStatus) $
38 when (statusCode status /= wantedStatus) $
34 left (requestString ++ " failed with status: " ++ showStatus status)
39 left (requestString ++ " failed with status: " ++ showStatus status)
40+ result <- either
35− result <- maybe (left (requestString ++ " returned invalid json")) return $
41+ (\ message -> left (requestString ++ " returned invalid json: " ++ message))
42+ return
36− decode' (Client.responseBody response)
43+ (decodeLenient (Client.responseBody response))
37 return result
44 return result
38 where
45 where
39 requestString = "HTTP " ++ cs method ++ " request"
46 requestString = "HTTP " ++ cs method ++ " request"
@@ -46,3 +53,10 @@ catchStatusCodeException action = catch (Right <$> action) $
46 Client.StatusCodeException status _ _ ->
53 Client.StatusCodeException status _ _ ->
47 return $ Left status
54 return $ Left status
48 e -> throwIO e
55 e -> throwIO e
56+
57+-- | Like 'Data.Aeson.decode' but allows all JSON values instead of just
58+-- objects and arrays.
59+decodeLenient :: FromJSON a => ByteString -> Either String a
60+decodeLenient input = do
61+ v :: Value <- parseOnly (Data.Aeson.Parser.value <* endOfInput) (cs input)
62+ parseEither parseJSON v
test/Servant/ClientSpec.hs+13−1
@@ -8,12 +8,14 @@ module Servant.ClientSpec where
8import Control.Concurrent
8import Control.Concurrent
9import Control.Exception
9import Control.Exception
10import Control.Monad.Trans.Either
10import Control.Monad.Trans.Either
11+import Data.Foldable
11import Data.Proxy
12import Data.Proxy
12import Data.Typeable
13import Data.Typeable
13import Network.Socket
14import Network.Socket
14import Network.URI
15import Network.URI
15import Network.Wai
16import Network.Wai
16import Network.Wai.Handler.Warp
17import Network.Wai.Handler.Warp
18+import Prelude hiding (mapM_)
17import Test.Hspec
19import Test.Hspec
18
20
19import Servant.API
21import Servant.API
@@ -28,6 +30,7 @@ type Api =
28 :<|> "body" :> ReqBody Person :> Post Person
30 :<|> "body" :> ReqBody Person :> Post Person
29 :<|> "param" :> QueryParam "name" String :> Get Person
31 :<|> "param" :> QueryParam "name" String :> Get Person
30 :<|> "params" :> QueryParams "names" String :> Get [Person]
32 :<|> "params" :> QueryParams "names" String :> Get [Person]
33+ :<|> "flag" :> QueryFlag "flag" :> Get Bool
31api :: Proxy Api
34api :: Proxy Api
32api = Proxy
35api = Proxy
33
36
@@ -41,6 +44,7 @@ server = serve api (
41 Just name -> left (400, name ++ " not found")
44 Just name -> left (400, name ++ " not found")
42 Nothing -> left (400, "missing parameter"))
45 Nothing -> left (400, "missing parameter"))
43 :<|> (\ names -> return (zipWith Person names [0..]))
46 :<|> (\ names -> return (zipWith Person names [0..]))
47+ :<|> return
44 )
48 )
45
49
46withServer :: (URIAuth -> IO a) -> IO a
50withServer :: (URIAuth -> IO a) -> IO a
@@ -51,11 +55,13 @@ getCapture :: String -> URIAuth -> EitherT String IO Person
51getBody :: Person -> URIAuth -> EitherT String IO Person
55getBody :: Person -> URIAuth -> EitherT String IO Person
52getQueryParam :: Maybe String -> URIAuth -> EitherT String IO Person
56getQueryParam :: Maybe String -> URIAuth -> EitherT String IO Person
53getQueryParams :: [String] -> URIAuth -> EitherT String IO [Person]
57getQueryParams :: [String] -> URIAuth -> EitherT String IO [Person]
58+getQueryFlag :: Bool -> URIAuth -> EitherT String IO Bool
54( getGet
59( getGet
55 :<|> getCapture
60 :<|> getCapture
56 :<|> getBody
61 :<|> getBody
57 :<|> getQueryParam
62 :<|> getQueryParam
58− :<|> getQueryParams)
63+ :<|> getQueryParams
64+ :<|> getQueryFlag)
59 = client api
65 = client api
60
66
61spec :: Spec
67spec :: Spec
@@ -80,6 +86,12 @@ spec = do
80 runEitherT (getQueryParams ["alice", "bob"] host)
86 runEitherT (getQueryParams ["alice", "bob"] host)
81 `shouldReturn` Right [Person "alice" 0, Person "bob" 1]
87 `shouldReturn` Right [Person "alice" 0, Person "bob" 1]
82
88
89+ context "Servant.API.QueryParam.QueryFlag" $
90+ forM_ [False, True] $ \ flag ->
91+ it (show flag) $ withServer $ \ host -> do
92+ runEitherT (getQueryFlag flag host) `shouldReturn` Right flag
93+
94+
83 context "client correctly handles error status codes" $ do
95 context "client correctly handles error status codes" $ do
84 let test :: WrappedApi -> Spec
96 let test :: WrappedApi -> Spec
85 test (WrappedApi api) =
97 test (WrappedApi api) =