From 16dbf9b188ee80baf46a6d9d47aa39669b56126f Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?S=C3=B6nke=20Hahn?= <soenkehahn@gmail.com>
Date: Fri, 31 Oct 2014 20:29:00 +0800
Subject: [PATCH] Allow arbitrary JSON values (not only arrays and objects)

And added tests for QueryFlag.
---
 servant.cabal               |  1 +
 src/Servant/Utils/Client.hs | 18 ++++++++++++++++--
 test/Servant/ClientSpec.hs  | 14 +++++++++++++-
 3 files changed, 30 insertions(+), 3 deletions(-)

diff --git a/servant.cabal b/servant.cabal
index 8968efdd..5066a48d 100644
--- a/servant.cabal
+++ b/servant.cabal
@@ -35,6 +35,7 @@ library
       base >=4.7 && <5
     , either
     , aeson
+    , attoparsec
     , bytestring
     , exceptions
     , string-conversions
diff --git a/src/Servant/Utils/Client.hs b/src/Servant/Utils/Client.hs
index b6a71e9b..b1c769f0 100644
--- a/src/Servant/Utils/Client.hs
+++ b/src/Servant/Utils/Client.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE ScopedTypeVariables #-}
 module Servant.Utils.Client where
 
 import Control.Applicative
@@ -6,6 +7,10 @@ import Control.Monad
 import Control.Monad.IO.Class
 import Control.Monad.Trans.Either
 import Data.Aeson
+import Data.Aeson.Parser
+import Data.Aeson.Types
+import Data.Attoparsec.ByteString
+import Data.ByteString.Lazy
 import Data.String.Conversions
 import Network.HTTP.Types
 import Network.URI
@@ -32,8 +37,10 @@ performRequest method req wantedStatus host = do
       let status = Client.responseStatus response
       when (statusCode status /= wantedStatus) $
         left (requestString ++ " failed with status: " ++ showStatus status)
-      result <- maybe (left (requestString ++ " returned invalid json")) return $
-        decode' (Client.responseBody response)
+      result <- either
+        (\ message -> left (requestString ++ " returned invalid json: " ++ message))
+        return
+        (decodeLenient (Client.responseBody response))
       return result
   where
     requestString = "HTTP " ++ cs method ++ " request"
@@ -46,3 +53,10 @@ catchStatusCodeException action = catch (Right <$> action) $
     Client.StatusCodeException status _ _ ->
       return $ Left status
     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
diff --git a/test/Servant/ClientSpec.hs b/test/Servant/ClientSpec.hs
index dba00192..5a62e754 100644
--- a/test/Servant/ClientSpec.hs
+++ b/test/Servant/ClientSpec.hs
@@ -8,12 +8,14 @@ module Servant.ClientSpec where
 import Control.Concurrent
 import Control.Exception
 import Control.Monad.Trans.Either
+import Data.Foldable
 import Data.Proxy
 import Data.Typeable
 import Network.Socket
 import Network.URI
 import Network.Wai
 import Network.Wai.Handler.Warp
+import Prelude hiding (mapM_)
 import Test.Hspec
 
 import Servant.API
@@ -28,6 +30,7 @@ type Api =
   :<|> "body" :> ReqBody Person :> Post Person
   :<|> "param" :> QueryParam "name" String :> Get Person
   :<|> "params" :> QueryParams "names" String :> Get [Person]
+  :<|> "flag" :> QueryFlag "flag" :> Get Bool
 api :: Proxy Api
 api = Proxy
 
@@ -41,6 +44,7 @@ server = serve api (
                    Just name -> left (400, name ++ " not found")
                    Nothing -> left (400, "missing parameter"))
   :<|> (\ names -> return (zipWith Person names [0..]))
+  :<|> return
  )
 
 withServer :: (URIAuth -> IO a) -> IO a
@@ -51,11 +55,13 @@ getCapture :: String -> URIAuth -> EitherT String IO Person
 getBody :: Person -> URIAuth -> EitherT String IO Person
 getQueryParam :: Maybe String -> URIAuth -> EitherT String IO Person
 getQueryParams :: [String] -> URIAuth -> EitherT String IO [Person]
+getQueryFlag :: Bool -> URIAuth -> EitherT String IO Bool
 (     getGet
  :<|> getCapture
  :<|> getBody
  :<|> getQueryParam
- :<|> getQueryParams)
+ :<|> getQueryParams
+ :<|> getQueryFlag)
     = client api
 
 spec :: Spec
@@ -80,6 +86,12 @@ spec = do
     runEitherT (getQueryParams ["alice", "bob"] host)
       `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
     let test :: WrappedApi -> Spec
         test (WrappedApi api) =