diff --git a/servant-quickcheck.cabal b/servant-quickcheck.cabal index 3289c79..df0141c 100644 --- a/servant-quickcheck.cabal +++ b/servant-quickcheck.cabal @@ -32,7 +32,7 @@ library , mtl == 2.2.* , http-client == 0.4.* , http-types == 0.9.* - , http-media + , http-media == 0.6.* , servant-client == 0.7.* , servant-server == 0.7.* , string-conversions == 0.4.* @@ -42,9 +42,12 @@ library , process == 1.2.* , temporary == 1.2.* , split == 0.2.* - , case-insensitive - , hspec + , case-insensitive == 1.2.* + , hspec == 2.2.* , text == 1.* + if impl(ghc < 7.10) + build-depends: bifunctors == 5.* + hs-source-dirs: src default-extensions: TypeOperators , FlexibleInstances diff --git a/src/Servant/QuickCheck/Internal/Predicates.hs b/src/Servant/QuickCheck/Internal/Predicates.hs index a0fad97..786df66 100644 --- a/src/Servant/QuickCheck/Internal/Predicates.hs +++ b/src/Servant/QuickCheck/Internal/Predicates.hs @@ -1,6 +1,6 @@ module Servant.QuickCheck.Internal.Predicates where -import Control.Monad +import Control.Monad (liftM2) import Data.Aeson (Object, decode) import Data.Bifunctor (Bifunctor (..)) import qualified Data.ByteString as SBS @@ -9,7 +9,7 @@ import qualified Data.ByteString.Lazy as LBS import Data.CaseInsensitive (mk) import Data.Either (isRight) import Data.List.Split (wordsBy) -import Data.Maybe (fromMaybe, isJust, maybeToList) +import Data.Maybe (fromMaybe, isJust) import Data.Monoid ((<>)) import Data.Text (Text) import GHC.Generics (Generic) @@ -21,7 +21,7 @@ import Network.HTTP.Media (matchAccept) import Network.HTTP.Types (methodGet, methodHead, parseMethod, renderStdMethod, status200, status201, status300, status401, status405, - status500) + status500, status100) -- | [__Best Practice__] -- @@ -129,6 +129,7 @@ notAllowedContainsAllowHeader go x = all (\y -> isRight $ parseMethod $ SBSC.pack y) $ wordsBy (`elem` (", " :: [Char])) (SBSC.unpack x) + -- | [__RFC Compliance__] -- -- When a request contains an @Accept@ header, the server must either return @@ -136,12 +137,13 @@ notAllowedContainsAllowHeader -- Acceptable@. -- -- This function checks that every *successful* response has a @Content-Type@ --- header that matches the @Accept@ header. +-- header that matches the @Accept@ header. It does *not* check that the server +-- matches the quality descriptions of the @Accept@ header correctly. -- -- __References__: -- -- * @Accept@ header: -honoursAcceptHeader :: RequestPredicate b Bool +honoursAcceptHeader :: RequestPredicate Text Bool honoursAcceptHeader = RequestPredicate { reqPredName = "honoursAcceptHeader" @@ -150,8 +152,8 @@ honoursAcceptHeader let scode = responseStatus resp sctype = lookup "Content-Type" $ responseHeaders resp sacc = fromMaybe "*/*" $ lookup "Accept" (requestHeaders req) - if 100 < scode && scode < 300 - then return (isJust $ sctype >>= \x -> matchAccept x sacc, [resp]) + if status100 < scode && scode < status300 + then return (isJust $ sctype >>= \x -> matchAccept [x] sacc, [resp]) else return (True, [resp]) }