From b1227d386463e00ebb9c79c25264b1db63da26ee Mon Sep 17 00:00:00 2001 From: "Julian K. Arni" Date: Tue, 18 Oct 2016 14:38:44 +0200 Subject: [PATCH] Make onlyJsonObjects succeed in non-JSON endpoints. --- CHANGELOG.yaml | 9 +++-- servant-quickcheck.cabal | 1 + src/Servant/QuickCheck/Internal/Predicates.hs | 31 +++++++++++------ test/Servant/QuickCheck/InternalSpec.hs | 34 +++++++++++++------ 4 files changed, 52 insertions(+), 23 deletions(-) diff --git a/CHANGELOG.yaml b/CHANGELOG.yaml index 0d79a6a..c11967f 100644 --- a/CHANGELOG.yaml +++ b/CHANGELOG.yaml @@ -1,5 +1,10 @@ upcoming: + - description: Make onlyJsonObjects succeed in non-JSON endpoints + issue: 20 + authors: jkarni + date: 2016-10-18 + releases: - version: "0.0.2.1" @@ -15,9 +20,9 @@ releases: authors: jkarni date: 2016-10-03 - - description: Raise upper bounds + - description: Raise upper bounds notes: > - For Quickcheck, aeson, http-client, servant, servant-client and + For Quickcheck, aeson, http-client, servant, servant-client and servant-server. pr: none authors: jkarni diff --git a/servant-quickcheck.cabal b/servant-quickcheck.cabal index d2d6751..144df2a 100644 --- a/servant-quickcheck.cabal +++ b/servant-quickcheck.cabal @@ -85,6 +85,7 @@ test-suite spec build-depends: base == 4.* , base-compat , servant-quickcheck + , bytestring , hspec , hspec-core , http-client diff --git a/src/Servant/QuickCheck/Internal/Predicates.hs b/src/Servant/QuickCheck/Internal/Predicates.hs index 4220250..6253d86 100644 --- a/src/Servant/QuickCheck/Internal/Predicates.hs +++ b/src/Servant/QuickCheck/Internal/Predicates.hs @@ -1,29 +1,32 @@ module Servant.QuickCheck.Internal.Predicates where import Control.Exception (catch, throw) -import Control.Monad (when, unless, liftM2) +import Control.Monad (liftM2, unless, when) import Data.Aeson (Object, decode) +import Data.Bifunctor (first) import qualified Data.ByteString as SBS import qualified Data.ByteString.Char8 as SBSC import qualified Data.ByteString.Lazy as LBS -import Data.CaseInsensitive (mk) +import Data.CaseInsensitive (mk, foldedCase) import Data.Either (isRight) import Data.List.Split (wordsBy) import Data.Maybe (fromMaybe, isJust) import Data.Monoid ((<>)) -import Data.Time (parseTimeM, defaultTimeLocale, - rfc822DateFormat, UTCTime) +import Data.Time (UTCTime, defaultTimeLocale, parseTimeM, + rfc822DateFormat) import GHC.Generics (Generic) import Network.HTTP.Client (Manager, Request, Response, httpLbs, - method, requestHeaders, responseBody, - responseHeaders, parseRequest, responseStatus) + method, parseRequest, requestHeaders, + responseBody, responseHeaders, + responseStatus) import Network.HTTP.Media (matchAccept) import Network.HTTP.Types (methodGet, methodHead, parseMethod, renderStdMethod, status100, status200, status201, status300, status401, status405, status500) -import System.Clock (toNanoSecs, Clock(Monotonic), getTime, diffTimeSpec) import Prelude.Compat +import System.Clock (Clock (Monotonic), diffTimeSpec, + getTime, toNanoSecs) import Servant.QuickCheck.Internal.ErrorTypes @@ -80,9 +83,15 @@ notLongerThan maxAllowed -- /Since 0.0.0.0/ onlyJsonObjects :: ResponsePredicate onlyJsonObjects - = ResponsePredicate (\resp -> case decode (responseBody resp) of + = ResponsePredicate (\resp -> case go resp of Nothing -> throw $ PredicateFailure "onlyJsonObjects" Nothing resp - Just (_ :: Object) -> return ()) + Just () -> return ()) + where + go r = do + ctyp <- lookup "content-type" (first foldedCase <$> responseHeaders r) + when ("application/json" `SBS.isPrefixOf` ctyp) $ do + (_ :: Object) <- decode (responseBody r) + return () -- | __Optional__ -- @@ -353,7 +362,7 @@ instance Monoid ResponsePredicate where -- -- /Since 0.0.0.0/ newtype RequestPredicate = RequestPredicate - { getRequestPredicate :: Request -> Manager -> IO [Response LBS.ByteString] + { getRequestPredicate :: Request -> Manager -> IO [Response LBS.ByteString] } deriving (Generic) -- TODO: This isn't actually a monoid @@ -364,7 +373,7 @@ instance Monoid RequestPredicate where -- | A set of predicates. Construct one with 'mempty' and '<%>'. data Predicates = Predicates - { requestPredicates :: RequestPredicate + { requestPredicates :: RequestPredicate , responsePredicates :: ResponsePredicate } deriving (Generic) diff --git a/test/Servant/QuickCheck/InternalSpec.hs b/test/Servant/QuickCheck/InternalSpec.hs index 71b790e..54c5159 100644 --- a/test/Servant/QuickCheck/InternalSpec.hs +++ b/test/Servant/QuickCheck/InternalSpec.hs @@ -1,20 +1,22 @@ {-# LANGUAGE CPP #-} module Servant.QuickCheck.InternalSpec (spec) where -import Control.Concurrent.MVar (newMVar, readMVar, swapMVar) -import Control.Monad.IO.Class (liftIO) -import Prelude.Compat -import Servant +import Control.Concurrent.MVar (newMVar, readMVar, swapMVar) +import Control.Monad.IO.Class (liftIO) +import qualified Data.ByteString as BS +import Prelude.Compat +import Servant +import Test.Hspec (Spec, context, describe, it, shouldBe, + shouldContain) +import Test.Hspec.Core.Spec (Arg, Example, Result (..), + defaultParams, evaluateExample) + #if MIN_VERSION_servant(0,8,0) import Servant.API.Internal.Test.ComprehensiveAPI (comprehensiveAPIWithoutRaw) #else -import Servant.API.Internal.Test.ComprehensiveAPI (comprehensiveAPI, ComprehensiveAPI) +import Servant.API.Internal.Test.ComprehensiveAPI (ComprehensiveAPI, + comprehensiveAPI) #endif -import Test.Hspec (Spec, context, describe, it, - shouldBe, shouldContain) -import Test.Hspec.Core.Spec (Arg, Example, Result (..), - defaultParams, - evaluateExample) import Servant.QuickCheck import Servant.QuickCheck.Internal (genRequest, serverDoesntSatisfy) @@ -81,6 +83,10 @@ onlyJsonObjectSpec = describe "onlyJsonObjects" $ do (onlyJsonObjects <%> mempty) err `shouldContain` "onlyJsonObjects" + it "accepts non-JSON endpoints" $ do + withServantServerAndContext octetAPI ctx serverOctetAPI $ \burl -> + serverSatisfies octetAPI burl args (onlyJsonObjects <%> mempty) + notLongerThanSpec :: Spec notLongerThanSpec = describe "notLongerThan" $ do @@ -132,6 +138,14 @@ server2 = return $ return 1 server3 :: IO (Server API2) server3 = return $ return 2 +type OctetAPI = Get '[OctetStream] BS.ByteString + +octetAPI :: Proxy OctetAPI +octetAPI = Proxy + +serverOctetAPI :: IO (Server OctetAPI) +serverOctetAPI = return $ return "blah" + ctx :: Context '[BasicAuthCheck ()] ctx = BasicAuthCheck (const . return $ NoSuchUser) :. EmptyContext ------------------------------------------------------------------------------