git.iko.soy/servant-quickcheck
on master help sign in
Add new predicates.
9307ea2Julian K. Arni
src/Servant/QuickCheck/Internal/HasGenRequest.hs+4
compare with master
unifiedsplit
@@ -130,3 +130,7 @@ instance (HasGenRequest a) => HasGenRequest (Vault :> a) where
130
130
131instance (HasGenRequest a) => HasGenRequest (WithNamedContext x y a) where
131instance (HasGenRequest a) => HasGenRequest (WithNamedContext x y a) where
132 genRequest _ = genRequest (Proxy :: Proxy a)
132 genRequest _ = genRequest (Proxy :: Proxy a)
133+
134+-- TODO: Try logging in
135+instance (HasGenRequest a) => HasGenRequest (BasicAuth x y :> a) where
136+ genRequest _ = genRequest (Proxy :: Proxy a)
src/Servant/QuickCheck/Internal/Predicates.hs+67−20
@@ -87,15 +87,26 @@ getsHaveLastModifiedHeader
87-- __References__:
87-- __References__:
88--
88--
89-- * @Allow@ header: <https://www.w3.org/Protocols/rfc2616/rfc2616-sec14.html RFC 2616 Section 14.7>
89-- * @Allow@ header: <https://www.w3.org/Protocols/rfc2616/rfc2616-sec14.html RFC 2616 Section 14.7>
90+-- * Status 405: <https://www.w3.org/Protocols/rfc2616/rfc2616-sec10.html RFC 2616 Section 10.4.6>
90−notAllowedContainsAllowHeader :: ResponsePredicate Text Bool
91+notAllowedContainsAllowHeader :: RequestPredicate Text Bool
91notAllowedContainsAllowHeader
92notAllowedContainsAllowHeader
93+ = RequestPredicate
94+ { reqPredName = name
95+ , reqResps = \req mgr -> mapM (flip httpLbs mgr)
96+ [ req { method = renderStdMethod m }
97+ | m <- [minBound .. maxBound ]
98+ , renderStdMethod m /= method req ]
99+ , reqPred = pred'
100+ }
101+ where
92− = ResponsePredicate "notAllowedContainsAllowHeader" (\resp ->
102+ name = "notAllowedContainsAllowHeader"
103+ pred' = ResponsePredicate name (\resp ->
93− if responseStatus resp == status405
104+ if responseStatus resp == status405
94− then hasValidHeader "Allow" go resp
105+ then hasValidHeader "Allow" go resp
95− else True)
106+ else True)
96− where
107+ where
97− go x = all (\y -> isRight $ parseMethod $ SBSC.pack y)
108+ go x = all (\y -> isRight $ parseMethod $ SBSC.pack y)
98− $ wordsBy (`elem` (", " :: [Char])) (SBSC.unpack x)
109+ $ wordsBy (`elem` (", " :: [Char])) (SBSC.unpack x)
99
110
100 {-
111 {-
101-- | When a request contains an @Accept@ header, the server must either return
112-- | When a request contains an @Accept@ header, the server must either return
@@ -104,28 +115,64 @@ notAllowedContainsAllowHeader
104--
115--
105-- This function checks that every *successful* response has a @Content-Type@
116-- This function checks that every *successful* response has a @Content-Type@
106-- header that matches the @Accept@ header.
117-- header that matches the @Accept@ header.
118+--
119+-- __References__:
120+--
121+-- * @Accept@ header: <https://www.w3.org/Protocols/rfc2616/rfc2616-sec14.html RFC 2616 Section 14.1>
107−honoursAcceptHeader :: Predicate b Bool
122+honoursAcceptHeader :: RequestPredicate b Bool
108honoursAcceptHeader
123honoursAcceptHeader
124+ = RequestPredicate name (ResponsePredicate name $ \req mgr -> do
125+
126+ resp <- httpLbs req mgr
127+ let scode = responseStatus resp
128+ sctype = maybeToList $ lookup "Content-Type" $ responseHeaders resp
129+ sacc = fromMaybe "*/*" $ lookup "Accept" $ requestHeaders req
130+ if 100 < scode && scode < 300
131+ then isJust matchAccept sacc sctype
132+ else True)
109− = RequestPredicate "honoursAcceptHeader" _
133+ where name = "honoursAcceptHeader"
110
134
135+-}
136+-- | [__Best Practice__]
137+--
111−-- | Whether or not a representation should be cached, it is good practice to
138+-- Whether or not a representation should be cached, it is good practice to
112-- have a @Cache-Control@ header for @GET@ requests. If the representation
139-- have a @Cache-Control@ header for @GET@ requests. If the representation
113-- should not be cached, used @Cache-Control: no-cache@.
140-- should not be cached, used @Cache-Control: no-cache@.
114--
141--
115−-- This function checks that @GET@ responses have a valid @Cache-Control@
142+-- This function checks that @GET@ responses have @Cache-Control@ header.
116−-- header.
143+-- It does NOT currently check that the header is valid.
144+--
145+-- __References__:
117--
146--
118−-- References: RFC 7234 Section 5.2
119−-- https://tools.ietf.org/html/rfc7234#section-5.2
147+-- * @Cache-Control@ header: <https://tools.ietf.org/html/rfc7234#section-5.2 RFC 7234 Section 5.2>
120−getsHaveCacheControlHeader :: Predicate b Bool
148+getsHaveCacheControlHeader :: RequestPredicate Text Bool
121getsHaveCacheControlHeader
149getsHaveCacheControlHeader
150+ = RequestPredicate
151+ { reqPredName = name
152+ , reqResps = \req mgr -> if method req == methodGet
153+ then return <$> httpLbs req mgr
154+ else return []
155+ , reqPred = ResponsePredicate name $ \resp ->
156+ isJust $ lookup "Cache-Control" $ responseHeaders resp
157+ }
122− = ResponsePredicate "getsHaveCacheControlHeader" _
158+ where name = "getsHaveCacheControlHeader"
123
159
160+-- | [__Best Practice__]
161+--
124−-- | Like 'getsHaveCacheControlHeader', but for @HEAD@ requests.
162+-- Like 'getsHaveCacheControlHeader', but for @HEAD@ requests.
125−headsHaveCacheControlHeader :: Predicate b Bool
163+headsHaveCacheControlHeader :: RequestPredicate Text Bool
126headsHaveCacheControlHeader
164headsHaveCacheControlHeader
165+ = RequestPredicate
166+ { reqPredName = name
167+ , reqResps = \req mgr -> if method req == methodHead
168+ then return <$> httpLbs req mgr
169+ else return []
170+ , reqPred = ResponsePredicate name $ \resp ->
171+ isJust $ lookup "Cache-Control" $ responseHeaders resp
172+ }
127− = ResponsePredicate "headsHaveCacheControlHeader" _
173+ where name = "headsHaveCacheControlHeader"
128
174
175+{-
129-- |
176-- |
130--
177--
131-- If the original request modifies the resource, this function makes two
178-- If the original request modifies the resource, this function makes two
src/Servant/QuickCheck/Internal/QuickCheck.hs+8−2
@@ -25,8 +25,14 @@ import Servant.QuickCheck.Internal.Equality
25-- then stop the application.
25-- then stop the application.
26withServantServer :: HasServer a '[] => Proxy a -> IO (Server a)
26withServantServer :: HasServer a '[] => Proxy a -> IO (Server a)
27 -> (BaseUrl -> IO r) -> IO r
27 -> (BaseUrl -> IO r) -> IO r
28−withServantServer api server t
28+withServantServer api = withServantServerAndContext api EmptyContext
29+
30+-- | Like 'withServantServer', but allows passing in a 'Context' to the
31+-- application.
32+withServantServerAndContext :: HasServer a ctx
33+ => Proxy a -> Context ctx -> IO (Server a) -> (BaseUrl -> IO r) -> IO r
34+withServantServerAndContext api ctx server t
29− = withApplication (return . serve api =<< server) $ \port ->
35+ = withApplication (return . serveWithContext api ctx =<< server) $ \port ->
30 t (BaseUrl Http "localhost" port "")
36 t (BaseUrl Http "localhost" port "")
31
37
32-- | Check that the two servers running under the provided @BaseUrl@s behave
38-- | Check that the two servers running under the provided @BaseUrl@s behave
test/Servant/QuickCheck/InternalSpec.hs+15−7
@@ -24,8 +24,8 @@ serversEqualSpec :: Spec
24serversEqualSpec = describe "serversEqual" $ do
24serversEqualSpec = describe "serversEqual" $ do
25
25
26 it "considers equal servers equal" $ do
26 it "considers equal servers equal" $ do
27− withServantServer api server $ \burl1 ->
27+ withServantServerAndContext api ctx server $ \burl1 ->
28− withServantServer api server $ \burl2 -> do
28+ withServantServerAndContext api ctx server $ \burl2 -> do
29 serversEqual api burl1 burl2 args bodyEquality
29 serversEqual api burl1 burl2 args bodyEquality
30
30
31
31
@@ -33,12 +33,17 @@ serverSatisfiesSpec :: Spec
33serverSatisfiesSpec = describe "serverSatisfies" $ do
33serverSatisfiesSpec = describe "serverSatisfies" $ do
34
34
35 it "succeeds for true predicates" $ do
35 it "succeeds for true predicates" $ do
36− withServantServer api server $ \burl ->
36+ withServantServerAndContext api ctx server $ \burl ->
37− serverSatisfies api burl args (not500 <%> mempty)
37+ serverSatisfies api burl args (unauthorizedContainsWWWAuthenticate
38+ <%> not500
39+ <%> mempty)
38
40
39 it "fails for false predicates" $ do
41 it "fails for false predicates" $ do
40− withServantServer api server $ \burl ->
42+ withServantServerAndContext api ctx server $ \burl -> do
43+ -- Since this is the negation, and we want to check that all of the
44+ -- predicates fail rather than one or more, we need to separate them out
41− serverSatisfies api burl args (onlyJsonObjects <%> mempty)
45+ serverSatisfies api burl args ((not <$> onlyJsonObjects) <%> mempty)
46+ serverSatisfies api burl args ((not <$> getsHaveCacheControlHeader) <%> mempty)
42
47
43isComprehensiveSpec :: Spec
48isComprehensiveSpec :: Spec
44isComprehensiveSpec = describe "HasGenRequest" $ do
49isComprehensiveSpec = describe "HasGenRequest" $ do
@@ -54,6 +59,7 @@ isComprehensiveSpec = describe "HasGenRequest" $ do
54
59
55type API = ReqBody '[JSON] String :> Post '[JSON] String
60type API = ReqBody '[JSON] String :> Post '[JSON] String
56 :<|> Get '[JSON] Int
61 :<|> Get '[JSON] Int
62+ :<|> BasicAuth "some-realm" () :> Get '[JSON] ()
57
63
58api :: Proxy API
64api :: Proxy API
59api = Proxy
65api = Proxy
@@ -63,8 +69,10 @@ server = do
63 mvar <- newMVar ""
69 mvar <- newMVar ""
64 return $ (\x -> liftIO $ swapMVar mvar x)
70 return $ (\x -> liftIO $ swapMVar mvar x)
65 :<|> (liftIO $ readMVar mvar >>= return . length)
71 :<|> (liftIO $ readMVar mvar >>= return . length)
72+ :<|> (const $ return ())
66
73
67−
74+ctx :: Context '[BasicAuthCheck ()]
75+ctx = BasicAuthCheck (const . return $ NoSuchUser) :. EmptyContext
68------------------------------------------------------------------------------
76------------------------------------------------------------------------------
69-- Utils
77-- Utils
70------------------------------------------------------------------------------
78------------------------------------------------------------------------------