diff --git a/CHANGELOG.yaml b/CHANGELOG.yaml --- a/CHANGELOG.yaml +++ b/CHANGELOG.yaml @@ -2,6 +2,15 @@ releases: + - version: "0.0.2.2" + changes: + + - description: Make onlyJsonObjects succeed in non-JSON endpoints + issue: 20 + authors: jkarni + date: 2016-10-18 + + - version: "0.0.2.1" changes: @@ -15,9 +24,9 @@ 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 --- a/servant-quickcheck.cabal +++ b/servant-quickcheck.cabal @@ -1,5 +1,5 @@ name: servant-quickcheck -version: 0.0.2.1 +version: 0.0.2.2 synopsis: QuickCheck entire APIs description: This packages provides QuickCheck properties that are tested across an entire @@ -85,6 +85,7 @@ 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 --- 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 @@ -- /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__ -- @@ -167,10 +176,13 @@ -- This function checks that every @405 Method Not Allowed@ response contains -- an @Allow@ header with a list of standard HTTP methods. -- +-- Note that 'servant' itself does not currently set the @Allow@ headers. +-- -- __References__: -- -- * @Allow@ header: -- * Status 405: +-- * Servant Allow header issue: -- -- /Since 0.0.0.0/ notAllowedContainsAllowHeader :: RequestPredicate @@ -350,7 +362,7 @@ -- -- /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 @@ -361,7 +373,7 @@ -- | 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 --- 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 @@ (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 @@ -131,6 +137,14 @@ 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