mirror of
https://github.com/ilyakooo0/servant-quickcheck.git
synced 2024-08-16 22:00:32 +03:00
Add new predicates.
* notAllowedContainsAllowHeader * getsHaveCacheControlHeader * headsHaveCacheControlHeader
This commit is contained in:
parent
b5ee965d1c
commit
9307ea2158
@ -130,3 +130,7 @@ instance (HasGenRequest a) => HasGenRequest (Vault :> a) where
|
|||||||
|
|
||||||
instance (HasGenRequest a) => HasGenRequest (WithNamedContext x y a) where
|
instance (HasGenRequest a) => HasGenRequest (WithNamedContext x y a) where
|
||||||
genRequest _ = genRequest (Proxy :: Proxy a)
|
genRequest _ = genRequest (Proxy :: Proxy a)
|
||||||
|
|
||||||
|
-- TODO: Try logging in
|
||||||
|
instance (HasGenRequest a) => HasGenRequest (BasicAuth x y :> a) where
|
||||||
|
genRequest _ = genRequest (Proxy :: Proxy a)
|
||||||
|
@ -87,15 +87,26 @@ getsHaveLastModifiedHeader
|
|||||||
-- __References__:
|
-- __References__:
|
||||||
--
|
--
|
||||||
-- * @Allow@ header: <https://www.w3.org/Protocols/rfc2616/rfc2616-sec14.html RFC 2616 Section 14.7>
|
-- * @Allow@ header: <https://www.w3.org/Protocols/rfc2616/rfc2616-sec14.html RFC 2616 Section 14.7>
|
||||||
notAllowedContainsAllowHeader :: ResponsePredicate Text Bool
|
-- * Status 405: <https://www.w3.org/Protocols/rfc2616/rfc2616-sec10.html RFC 2616 Section 10.4.6>
|
||||||
|
notAllowedContainsAllowHeader :: RequestPredicate Text Bool
|
||||||
notAllowedContainsAllowHeader
|
notAllowedContainsAllowHeader
|
||||||
= ResponsePredicate "notAllowedContainsAllowHeader" (\resp ->
|
= RequestPredicate
|
||||||
if responseStatus resp == status405
|
{ reqPredName = name
|
||||||
then hasValidHeader "Allow" go resp
|
, reqResps = \req mgr -> mapM (flip httpLbs mgr)
|
||||||
else True)
|
[ req { method = renderStdMethod m }
|
||||||
where
|
| m <- [minBound .. maxBound ]
|
||||||
go x = all (\y -> isRight $ parseMethod $ SBSC.pack y)
|
, renderStdMethod m /= method req ]
|
||||||
$ wordsBy (`elem` (", " :: [Char])) (SBSC.unpack x)
|
, reqPred = pred'
|
||||||
|
}
|
||||||
|
where
|
||||||
|
name = "notAllowedContainsAllowHeader"
|
||||||
|
pred' = ResponsePredicate name (\resp ->
|
||||||
|
if responseStatus resp == status405
|
||||||
|
then hasValidHeader "Allow" go resp
|
||||||
|
else True)
|
||||||
|
where
|
||||||
|
go x = all (\y -> isRight $ parseMethod $ SBSC.pack y)
|
||||||
|
$ wordsBy (`elem` (", " :: [Char])) (SBSC.unpack x)
|
||||||
|
|
||||||
{-
|
{-
|
||||||
-- | When a request contains an @Accept@ header, the server must either return
|
-- | When a request contains an @Accept@ header, the server must either return
|
||||||
@ -104,28 +115,64 @@ notAllowedContainsAllowHeader
|
|||||||
--
|
--
|
||||||
-- This function checks that every *successful* response has a @Content-Type@
|
-- This function checks that every *successful* response has a @Content-Type@
|
||||||
-- header that matches the @Accept@ header.
|
-- header that matches the @Accept@ header.
|
||||||
honoursAcceptHeader :: Predicate b Bool
|
--
|
||||||
|
-- __References__:
|
||||||
|
--
|
||||||
|
-- * @Accept@ header: <https://www.w3.org/Protocols/rfc2616/rfc2616-sec14.html RFC 2616 Section 14.1>
|
||||||
|
honoursAcceptHeader :: RequestPredicate b Bool
|
||||||
honoursAcceptHeader
|
honoursAcceptHeader
|
||||||
= RequestPredicate "honoursAcceptHeader" _
|
= RequestPredicate name (ResponsePredicate name $ \req mgr -> do
|
||||||
|
|
||||||
-- | Whether or not a representation should be cached, it is good practice to
|
resp <- httpLbs req mgr
|
||||||
|
let scode = responseStatus resp
|
||||||
|
sctype = maybeToList $ lookup "Content-Type" $ responseHeaders resp
|
||||||
|
sacc = fromMaybe "*/*" $ lookup "Accept" $ requestHeaders req
|
||||||
|
if 100 < scode && scode < 300
|
||||||
|
then isJust matchAccept sacc sctype
|
||||||
|
else True)
|
||||||
|
where name = "honoursAcceptHeader"
|
||||||
|
|
||||||
|
-}
|
||||||
|
-- | [__Best Practice__]
|
||||||
|
--
|
||||||
|
-- Whether or not a representation should be cached, it is good practice to
|
||||||
-- have a @Cache-Control@ header for @GET@ requests. If the representation
|
-- have a @Cache-Control@ header for @GET@ requests. If the representation
|
||||||
-- should not be cached, used @Cache-Control: no-cache@.
|
-- should not be cached, used @Cache-Control: no-cache@.
|
||||||
--
|
--
|
||||||
-- This function checks that @GET@ responses have a valid @Cache-Control@
|
-- This function checks that @GET@ responses have @Cache-Control@ header.
|
||||||
-- header.
|
-- It does NOT currently check that the header is valid.
|
||||||
--
|
--
|
||||||
-- References: RFC 7234 Section 5.2
|
-- __References__:
|
||||||
-- https://tools.ietf.org/html/rfc7234#section-5.2
|
--
|
||||||
getsHaveCacheControlHeader :: Predicate b Bool
|
-- * @Cache-Control@ header: <https://tools.ietf.org/html/rfc7234#section-5.2 RFC 7234 Section 5.2>
|
||||||
|
getsHaveCacheControlHeader :: RequestPredicate Text Bool
|
||||||
getsHaveCacheControlHeader
|
getsHaveCacheControlHeader
|
||||||
= ResponsePredicate "getsHaveCacheControlHeader" _
|
= RequestPredicate
|
||||||
|
{ reqPredName = name
|
||||||
|
, reqResps = \req mgr -> if method req == methodGet
|
||||||
|
then return <$> httpLbs req mgr
|
||||||
|
else return []
|
||||||
|
, reqPred = ResponsePredicate name $ \resp ->
|
||||||
|
isJust $ lookup "Cache-Control" $ responseHeaders resp
|
||||||
|
}
|
||||||
|
where name = "getsHaveCacheControlHeader"
|
||||||
|
|
||||||
-- | Like 'getsHaveCacheControlHeader', but for @HEAD@ requests.
|
-- | [__Best Practice__]
|
||||||
headsHaveCacheControlHeader :: Predicate b Bool
|
--
|
||||||
|
-- Like 'getsHaveCacheControlHeader', but for @HEAD@ requests.
|
||||||
|
headsHaveCacheControlHeader :: RequestPredicate Text Bool
|
||||||
headsHaveCacheControlHeader
|
headsHaveCacheControlHeader
|
||||||
= ResponsePredicate "headsHaveCacheControlHeader" _
|
= RequestPredicate
|
||||||
|
{ reqPredName = name
|
||||||
|
, reqResps = \req mgr -> if method req == methodHead
|
||||||
|
then return <$> httpLbs req mgr
|
||||||
|
else return []
|
||||||
|
, reqPred = ResponsePredicate name $ \resp ->
|
||||||
|
isJust $ lookup "Cache-Control" $ responseHeaders resp
|
||||||
|
}
|
||||||
|
where name = "headsHaveCacheControlHeader"
|
||||||
|
|
||||||
|
{-
|
||||||
-- |
|
-- |
|
||||||
--
|
--
|
||||||
-- If the original request modifies the resource, this function makes two
|
-- If the original request modifies the resource, this function makes two
|
||||||
|
@ -25,8 +25,14 @@ import Servant.QuickCheck.Internal.Equality
|
|||||||
-- then stop the application.
|
-- then stop the application.
|
||||||
withServantServer :: HasServer a '[] => Proxy a -> IO (Server a)
|
withServantServer :: HasServer a '[] => Proxy a -> IO (Server a)
|
||||||
-> (BaseUrl -> IO r) -> IO r
|
-> (BaseUrl -> IO r) -> IO r
|
||||||
withServantServer api server t
|
withServantServer api = withServantServerAndContext api EmptyContext
|
||||||
= withApplication (return . serve api =<< server) $ \port ->
|
|
||||||
|
-- | Like 'withServantServer', but allows passing in a 'Context' to the
|
||||||
|
-- application.
|
||||||
|
withServantServerAndContext :: HasServer a ctx
|
||||||
|
=> Proxy a -> Context ctx -> IO (Server a) -> (BaseUrl -> IO r) -> IO r
|
||||||
|
withServantServerAndContext api ctx server t
|
||||||
|
= withApplication (return . serveWithContext api ctx =<< server) $ \port ->
|
||||||
t (BaseUrl Http "localhost" port "")
|
t (BaseUrl Http "localhost" port "")
|
||||||
|
|
||||||
-- | Check that the two servers running under the provided @BaseUrl@s behave
|
-- | Check that the two servers running under the provided @BaseUrl@s behave
|
||||||
|
@ -24,8 +24,8 @@ serversEqualSpec :: Spec
|
|||||||
serversEqualSpec = describe "serversEqual" $ do
|
serversEqualSpec = describe "serversEqual" $ do
|
||||||
|
|
||||||
it "considers equal servers equal" $ do
|
it "considers equal servers equal" $ do
|
||||||
withServantServer api server $ \burl1 ->
|
withServantServerAndContext api ctx server $ \burl1 ->
|
||||||
withServantServer api server $ \burl2 -> do
|
withServantServerAndContext api ctx server $ \burl2 -> do
|
||||||
serversEqual api burl1 burl2 args bodyEquality
|
serversEqual api burl1 burl2 args bodyEquality
|
||||||
|
|
||||||
|
|
||||||
@ -33,12 +33,17 @@ serverSatisfiesSpec :: Spec
|
|||||||
serverSatisfiesSpec = describe "serverSatisfies" $ do
|
serverSatisfiesSpec = describe "serverSatisfies" $ do
|
||||||
|
|
||||||
it "succeeds for true predicates" $ do
|
it "succeeds for true predicates" $ do
|
||||||
withServantServer api server $ \burl ->
|
withServantServerAndContext api ctx server $ \burl ->
|
||||||
serverSatisfies api burl args (not500 <%> mempty)
|
serverSatisfies api burl args (unauthorizedContainsWWWAuthenticate
|
||||||
|
<%> not500
|
||||||
|
<%> mempty)
|
||||||
|
|
||||||
it "fails for false predicates" $ do
|
it "fails for false predicates" $ do
|
||||||
withServantServer api server $ \burl ->
|
withServantServerAndContext api ctx server $ \burl -> do
|
||||||
serverSatisfies api burl args (onlyJsonObjects <%> mempty)
|
-- Since this is the negation, and we want to check that all of the
|
||||||
|
-- predicates fail rather than one or more, we need to separate them out
|
||||||
|
serverSatisfies api burl args ((not <$> onlyJsonObjects) <%> mempty)
|
||||||
|
serverSatisfies api burl args ((not <$> getsHaveCacheControlHeader) <%> mempty)
|
||||||
|
|
||||||
isComprehensiveSpec :: Spec
|
isComprehensiveSpec :: Spec
|
||||||
isComprehensiveSpec = describe "HasGenRequest" $ do
|
isComprehensiveSpec = describe "HasGenRequest" $ do
|
||||||
@ -54,6 +59,7 @@ isComprehensiveSpec = describe "HasGenRequest" $ do
|
|||||||
|
|
||||||
type API = ReqBody '[JSON] String :> Post '[JSON] String
|
type API = ReqBody '[JSON] String :> Post '[JSON] String
|
||||||
:<|> Get '[JSON] Int
|
:<|> Get '[JSON] Int
|
||||||
|
:<|> BasicAuth "some-realm" () :> Get '[JSON] ()
|
||||||
|
|
||||||
api :: Proxy API
|
api :: Proxy API
|
||||||
api = Proxy
|
api = Proxy
|
||||||
@ -63,8 +69,10 @@ server = do
|
|||||||
mvar <- newMVar ""
|
mvar <- newMVar ""
|
||||||
return $ (\x -> liftIO $ swapMVar mvar x)
|
return $ (\x -> liftIO $ swapMVar mvar x)
|
||||||
:<|> (liftIO $ readMVar mvar >>= return . length)
|
:<|> (liftIO $ readMVar mvar >>= return . length)
|
||||||
|
:<|> (const $ return ())
|
||||||
|
|
||||||
|
ctx :: Context '[BasicAuthCheck ()]
|
||||||
|
ctx = BasicAuthCheck (const . return $ NoSuchUser) :. EmptyContext
|
||||||
------------------------------------------------------------------------------
|
------------------------------------------------------------------------------
|
||||||
-- Utils
|
-- Utils
|
||||||
------------------------------------------------------------------------------
|
------------------------------------------------------------------------------
|
||||||
|
Loading…
Reference in New Issue
Block a user