git.iko.soy/servant-quickcheck
on master help sign in
Bifunctors for GHC < 7.10.
b48b1e8Julian K. Arni
servant-quickcheck.cabal+6−3
compare with master
unifiedsplit
@@ -32,7 +32,7 @@ library
32 , mtl == 2.2.*
32 , mtl == 2.2.*
33 , http-client == 0.4.*
33 , http-client == 0.4.*
34 , http-types == 0.9.*
34 , http-types == 0.9.*
35− , http-media
35+ , http-media == 0.6.*
36 , servant-client == 0.7.*
36 , servant-client == 0.7.*
37 , servant-server == 0.7.*
37 , servant-server == 0.7.*
38 , string-conversions == 0.4.*
38 , string-conversions == 0.4.*
@@ -42,9 +42,12 @@ library
42 , process == 1.2.*
42 , process == 1.2.*
43 , temporary == 1.2.*
43 , temporary == 1.2.*
44 , split == 0.2.*
44 , split == 0.2.*
45− , case-insensitive
45+ , case-insensitive == 1.2.*
46− , hspec
46+ , hspec == 2.2.*
47 , text == 1.*
47 , text == 1.*
48+ if impl(ghc < 7.10)
49+ build-depends: bifunctors == 5.*
50+
48 hs-source-dirs: src
51 hs-source-dirs: src
49 default-extensions: TypeOperators
52 default-extensions: TypeOperators
50 , FlexibleInstances
53 , FlexibleInstances
src/Servant/QuickCheck/Internal/Predicates.hs+9−7
@@ -1,6 +1,6 @@
1module Servant.QuickCheck.Internal.Predicates where
1module Servant.QuickCheck.Internal.Predicates where
2
2
3−import Control.Monad
3+import Control.Monad (liftM2)
4import Data.Aeson (Object, decode)
4import Data.Aeson (Object, decode)
5import Data.Bifunctor (Bifunctor (..))
5import Data.Bifunctor (Bifunctor (..))
6import qualified Data.ByteString as SBS
6import qualified Data.ByteString as SBS
@@ -9,7 +9,7 @@ import qualified Data.ByteString.Lazy as LBS
9import Data.CaseInsensitive (mk)
9import Data.CaseInsensitive (mk)
10import Data.Either (isRight)
10import Data.Either (isRight)
11import Data.List.Split (wordsBy)
11import Data.List.Split (wordsBy)
12−import Data.Maybe (fromMaybe, isJust, maybeToList)
12+import Data.Maybe (fromMaybe, isJust)
13import Data.Monoid ((<>))
13import Data.Monoid ((<>))
14import Data.Text (Text)
14import Data.Text (Text)
15import GHC.Generics (Generic)
15import GHC.Generics (Generic)
@@ -21,7 +21,7 @@ import Network.HTTP.Media (matchAccept)
21import Network.HTTP.Types (methodGet, methodHead, parseMethod,
21import Network.HTTP.Types (methodGet, methodHead, parseMethod,
22 renderStdMethod, status200, status201,
22 renderStdMethod, status200, status201,
23 status300, status401, status405,
23 status300, status401, status405,
24− status500)
24+ status500, status100)
25
25
26-- | [__Best Practice__]
26-- | [__Best Practice__]
27--
27--
@@ -129,6 +129,7 @@ notAllowedContainsAllowHeader
129 go x = all (\y -> isRight $ parseMethod $ SBSC.pack y)
129 go x = all (\y -> isRight $ parseMethod $ SBSC.pack y)
130 $ wordsBy (`elem` (", " :: [Char])) (SBSC.unpack x)
130 $ wordsBy (`elem` (", " :: [Char])) (SBSC.unpack x)
131
131
132+
132-- | [__RFC Compliance__]
133-- | [__RFC Compliance__]
133--
134--
134-- When a request contains an @Accept@ header, the server must either return
135-- When a request contains an @Accept@ header, the server must either return
@@ -136,12 +137,13 @@ notAllowedContainsAllowHeader
136-- Acceptable@.
137-- Acceptable@.
137--
138--
138-- This function checks that every *successful* response has a @Content-Type@
139-- 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.
140--
142--
141-- __References__:
143-- __References__:
142--
144--
143-- * @Accept@ header: <https://www.w3.org/Protocols/rfc2616/rfc2616-sec14.html RFC 2616 Section 14.1>
145-- * @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
145honoursAcceptHeader
147honoursAcceptHeader
146 = RequestPredicate
148 = RequestPredicate
147 { reqPredName = "honoursAcceptHeader"
149 { reqPredName = "honoursAcceptHeader"
@@ -150,8 +152,8 @@ honoursAcceptHeader
150 let scode = responseStatus resp
152 let scode = responseStatus resp
151 sctype = lookup "Content-Type" $ responseHeaders resp
153 sctype = lookup "Content-Type" $ responseHeaders resp
152 sacc = fromMaybe "*/*" $ lookup "Accept" (requestHeaders req)
154 sacc = fromMaybe "*/*" $ lookup "Accept" (requestHeaders req)
153− if 100 < scode && scode < 300
155+ if status100 < scode && scode < status300
154− then return (isJust $ sctype >>= \x -> matchAccept x sacc, [resp])
156+ then return (isJust $ sctype >>= \x -> matchAccept [x] sacc, [resp])
155 else return (True, [resp])
157 else return (True, [resp])
156 }
158 }
157
159