haskell/servant-quickcheck
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Make onlyJsonObjects succeed in non-JSON endpoints.

Browse Source
This commit is contained in:
Julian K. Arni 2016-10-18 14:38:44 +02:00
parent 4f5e6ba25a
commit b1227d3864
4 changed files with 52 additions and 23 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

9
CHANGELOG.yaml
View File

@ -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

1
servant-quickcheck.cabal
View File

@ -85,6 +85,7 @@ test-suite spec
build-depends: base == 4.*
, base-compat
, servant-quickcheck
, bytestring
, hspec
, hspec-core
, http-client

31
src/Servant/QuickCheck/Internal/Predicates.hs
View File

@ -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)

34
test/Servant/QuickCheck/InternalSpec.hs
View File

@ -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
------------------------------------------------------------------------------