b48b1e8 · servant-quickcheck

git.iko.soy/servant-quickcheck

Bifunctors for GHC < 7.10.

And finish honoursAcceptHeader.

commitb48b1e8bc13697768ca6724893efe766df2de4eb authorJulian K. Arni <jkarni@gmail.com> dateMon 9 May 2016, 17:24 (10 years ago) parent530fdba

2 files changed+15−10

compare with master

unifiedsplit

servant-quickcheck.cabal+6−3 src/Servant/QuickCheck/Internal/Predicates.hs+9−7

servant-quickcheck.cabal+6−3

@@ -32,7 +32,7 @@ library

3232 , mtl == 2.2.*

3333 , http-client == 0.4.*

3434 , http-types == 0.9.*

35− , http-media

35+ , http-media == 0.6.*

3636 , servant-client == 0.7.*

3737 , servant-server == 0.7.*

3838 , string-conversions == 0.4.*

@@ -42,9 +42,12 @@ library

4242 , process == 1.2.*

4343 , temporary == 1.2.*

4444 , split == 0.2.*

45− , case-insensitive

46− , hspec

45+ , case-insensitive == 1.2.*

46+ , hspec == 2.2.*

4747 , text == 1.*

48+ if impl(ghc < 7.10)

49+ build-depends: bifunctors == 5.*

50+

4851 hs-source-dirs: src

4952 default-extensions: TypeOperators

5053 , FlexibleInstances

src/Servant/QuickCheck/Internal/Predicates.hs+9−7

@@ -1,6 +1,6 @@

11module Servant.QuickCheck.Internal.Predicates where

3−import Control.Monad

3+import Control.Monad (liftM2)

44import Data.Aeson (Object, decode)

55import Data.Bifunctor (Bifunctor (..))

66import qualified Data.ByteString as SBS

@@ -9,7 +9,7 @@ import qualified Data.ByteString.Lazy as LBS

99import Data.CaseInsensitive (mk)

1010import Data.Either (isRight)

1111import Data.List.Split (wordsBy)

12−import Data.Maybe (fromMaybe, isJust, maybeToList)

12+import Data.Maybe (fromMaybe, isJust)

1313import Data.Monoid ((<>))

1414import Data.Text (Text)

1515import GHC.Generics (Generic)

@@ -21,7 +21,7 @@ import Network.HTTP.Media (matchAccept)

2121import Network.HTTP.Types (methodGet, methodHead, parseMethod,

2222 renderStdMethod, status200, status201,

2323 status300, status401, status405,

24− status500)

24+ status500, status100)

2525

2626-- | [__Best Practice__]

2727--

@@ -129,6 +129,7 @@ notAllowedContainsAllowHeader

129129 go x = all (\y -> isRight $ parseMethod $ SBSC.pack y)

130130 $ wordsBy (`elem` (", " :: [Char])) (SBSC.unpack x)

131131

132+

132133-- | [__RFC Compliance__]

133134--

134135-- When a request contains an @Accept@ header, the server must either return

@@ -136,12 +137,13 @@ notAllowedContainsAllowHeader

136137-- Acceptable@.

137138--

138139-- This function checks that every *successful* response has a @Content-Type@

139−-- header that matches the @Accept@ header.

140+-- header that matches the @Accept@ header. It does *not* check that the server

141+-- matches the quality descriptions of the @Accept@ header correctly.

140142--

141143-- __References__:

142144--

143145-- * @Accept@ header: <https://www.w3.org/Protocols/rfc2616/rfc2616-sec14.html RFC 2616 Section 14.1>

144−honoursAcceptHeader :: RequestPredicate b Bool

146+honoursAcceptHeader :: RequestPredicate Text Bool

145147honoursAcceptHeader

146148 = RequestPredicate

147149 { reqPredName = "honoursAcceptHeader"

@@ -150,8 +152,8 @@ honoursAcceptHeader

150152 let scode = responseStatus resp

151153 sctype = lookup "Content-Type" $ responseHeaders resp

152154 sacc = fromMaybe "*/*" $ lookup "Accept" (requestHeaders req)

153− if 100 < scode && scode < 300

154− then return (isJust $ sctype >>= \x -> matchAccept x sacc, [resp])

155+ if status100 < scode && scode < status300

156+ then return (isJust $ sctype >>= \x -> matchAccept [x] sacc, [resp])

155157 else return (True, [resp])

156158 }

157159