servant-quickcheck 0.0.2.1 → 0.0.2.2
raw patch · 4 files changed
+60/−24 lines, 4 filesdep ~bytestring
Dependency ranges changed: bytestring
Files
- CHANGELOG.yaml +11/−2
- servant-quickcheck.cabal +2/−1
- src/Servant/QuickCheck/Internal/Predicates.hs +23/−11
- test/Servant/QuickCheck/InternalSpec.hs +24/−10
CHANGELOG.yaml view
@@ -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
servant-quickcheck.cabal view
@@ -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
src/Servant/QuickCheck/Internal/Predicates.hs view
@@ -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: <https://www.w3.org/Protocols/rfc2616/rfc2616-sec14.html RFC 2616 Section 14.7> -- * Status 405: <https://www.w3.org/Protocols/rfc2616/rfc2616-sec10.html RFC 2616 Section 10.4.6>+-- * Servant Allow header issue: <https://github.com/haskell-servant/servant/issues/489 Issue #489> -- -- /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)
test/Servant/QuickCheck/InternalSpec.hs view
@@ -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