git.iko.soy/servant-quickcheck
on master help sign in
Make onlyJsonObjects succeed in non-JSON endpoints.
commitb1227d386463e00ebb9c79c25264b1db63da26ee authorJulian K. Arni <jkarni@gmail.com> dateTue 18 Oct 2016, 14:38 (10 years ago) parent4f5e6ba
4 files changed+52−23
compare with master
unifiedsplit
CHANGELOG.yaml+7−2 servant-quickcheck.cabal+1 src/Servant/QuickCheck/Internal/Predicates.hs+20−11 test/Servant/QuickCheck/InternalSpec.hs+24−10
CHANGELOG.yaml+7−2
@@ -1,5 +1,10 @@
11upcoming:
22
3+ - description: Make onlyJsonObjects succeed in non-JSON endpoints
4+ issue: 20
5+ authors: jkarni
6+ date: 2016-10-18
7+
38releases:
49
510 - version: "0.0.2.1"
@@ -15,9 +20,9 @@ releases:
1520 authors: jkarni
1621 date: 2016-10-03
1722
18− - description: Raise upper bounds
23+ - description: Raise upper bounds
1924 notes: >
20− For Quickcheck, aeson, http-client, servant, servant-client and
25+ For Quickcheck, aeson, http-client, servant, servant-client and
2126 servant-server.
2227 pr: none
2328 authors: jkarni
servant-quickcheck.cabal+1
@@ -85,6 +85,7 @@ test-suite spec
8585 build-depends: base == 4.*
8686 , base-compat
8787 , servant-quickcheck
88+ , bytestring
8889 , hspec
8990 , hspec-core
9091 , http-client
src/Servant/QuickCheck/Internal/Predicates.hs+20−11
@@ -1,29 +1,32 @@
11module Servant.QuickCheck.Internal.Predicates where
22
33import Control.Exception (catch, throw)
4−import Control.Monad (when, unless, liftM2)
4+import Control.Monad (liftM2, unless, when)
55import Data.Aeson (Object, decode)
6+import Data.Bifunctor (first)
67import qualified Data.ByteString as SBS
78import qualified Data.ByteString.Char8 as SBSC
89import qualified Data.ByteString.Lazy as LBS
9−import Data.CaseInsensitive (mk)
10+import Data.CaseInsensitive (mk, foldedCase)
1011import Data.Either (isRight)
1112import Data.List.Split (wordsBy)
1213import Data.Maybe (fromMaybe, isJust)
1314import Data.Monoid ((<>))
14−import Data.Time (parseTimeM, defaultTimeLocale,
15− rfc822DateFormat, UTCTime)
15+import Data.Time (UTCTime, defaultTimeLocale, parseTimeM,
16+ rfc822DateFormat)
1617import GHC.Generics (Generic)
1718import Network.HTTP.Client (Manager, Request, Response, httpLbs,
18− method, requestHeaders, responseBody,
19− responseHeaders, parseRequest, responseStatus)
19+ method, parseRequest, requestHeaders,
20+ responseBody, responseHeaders,
21+ responseStatus)
2022import Network.HTTP.Media (matchAccept)
2123import Network.HTTP.Types (methodGet, methodHead, parseMethod,
2224 renderStdMethod, status100, status200,
2325 status201, status300, status401,
2426 status405, status500)
25−import System.Clock (toNanoSecs, Clock(Monotonic), getTime, diffTimeSpec)
2627import Prelude.Compat
28+import System.Clock (Clock (Monotonic), diffTimeSpec,
29+ getTime, toNanoSecs)
2730
2831import Servant.QuickCheck.Internal.ErrorTypes
2932
@@ -80,9 +83,15 @@ notLongerThan maxAllowed
8083-- /Since 0.0.0.0/
8184onlyJsonObjects :: ResponsePredicate
8285onlyJsonObjects
83− = ResponsePredicate (\resp -> case decode (responseBody resp) of
86+ = ResponsePredicate (\resp -> case go resp of
8487 Nothing -> throw $ PredicateFailure "onlyJsonObjects" Nothing resp
85− Just (_ :: Object) -> return ())
88+ Just () -> return ())
89+ where
90+ go r = do
91+ ctyp <- lookup "content-type" (first foldedCase <$> responseHeaders r)
92+ when ("application/json" `SBS.isPrefixOf` ctyp) $ do
93+ (_ :: Object) <- decode (responseBody r)
94+ return ()
8695
8796-- | __Optional__
8897--
@@ -353,7 +362,7 @@ instance Monoid ResponsePredicate where
353362--
354363-- /Since 0.0.0.0/
355364newtype RequestPredicate = RequestPredicate
356− { getRequestPredicate :: Request -> Manager -> IO [Response LBS.ByteString]
365+ { getRequestPredicate :: Request -> Manager -> IO [Response LBS.ByteString]
357366 } deriving (Generic)
358367
359368-- TODO: This isn't actually a monoid
@@ -364,7 +373,7 @@ instance Monoid RequestPredicate where
364373
365374-- | A set of predicates. Construct one with 'mempty' and '<%>'.
366375data Predicates = Predicates
367− { requestPredicates :: RequestPredicate
376+ { requestPredicates :: RequestPredicate
368377 , responsePredicates :: ResponsePredicate
369378 } deriving (Generic)
370379
test/Servant/QuickCheck/InternalSpec.hs+24−10
@@ -1,20 +1,22 @@
11{-# LANGUAGE CPP #-}
22module Servant.QuickCheck.InternalSpec (spec) where
33
4−import Control.Concurrent.MVar (newMVar, readMVar, swapMVar)
5−import Control.Monad.IO.Class (liftIO)
6−import Prelude.Compat
7−import Servant
4+import Control.Concurrent.MVar (newMVar, readMVar, swapMVar)
5+import Control.Monad.IO.Class (liftIO)
6+import qualified Data.ByteString as BS
7+import Prelude.Compat
8+import Servant
9+import Test.Hspec (Spec, context, describe, it, shouldBe,
10+ shouldContain)
11+import Test.Hspec.Core.Spec (Arg, Example, Result (..),
12+ defaultParams, evaluateExample)
13+
814#if MIN_VERSION_servant(0,8,0)
915import Servant.API.Internal.Test.ComprehensiveAPI (comprehensiveAPIWithoutRaw)
1016#else
11−import Servant.API.Internal.Test.ComprehensiveAPI (comprehensiveAPI, ComprehensiveAPI)
17+import Servant.API.Internal.Test.ComprehensiveAPI (ComprehensiveAPI,
18+ comprehensiveAPI)
1219#endif
13−import Test.Hspec (Spec, context, describe, it,
14− shouldBe, shouldContain)
15−import Test.Hspec.Core.Spec (Arg, Example, Result (..),
16− defaultParams,
17− evaluateExample)
1820
1921import Servant.QuickCheck
2022import Servant.QuickCheck.Internal (genRequest, serverDoesntSatisfy)
@@ -81,6 +83,10 @@ onlyJsonObjectSpec = describe "onlyJsonObjects" $ do
8183 (onlyJsonObjects <%> mempty)
8284 err `shouldContain` "onlyJsonObjects"
8385
86+ it "accepts non-JSON endpoints" $ do
87+ withServantServerAndContext octetAPI ctx serverOctetAPI $ \burl ->
88+ serverSatisfies octetAPI burl args (onlyJsonObjects <%> mempty)
89+
8490notLongerThanSpec :: Spec
8591notLongerThanSpec = describe "notLongerThan" $ do
8692
@@ -132,6 +138,14 @@ server2 = return $ return 1
132138server3 :: IO (Server API2)
133139server3 = return $ return 2
134140
141+type OctetAPI = Get '[OctetStream] BS.ByteString
142+
143+octetAPI :: Proxy OctetAPI
144+octetAPI = Proxy
145+
146+serverOctetAPI :: IO (Server OctetAPI)
147+serverOctetAPI = return $ return "blah"
148+
135149ctx :: Context '[BasicAuthCheck ()]
136150ctx = BasicAuthCheck (const . return $ NoSuchUser) :. EmptyContext
137151------------------------------------------------------------------------------