From 9307ea21584067e8fafb4451ca3247ec3f549270 Mon Sep 17 00:00:00 2001 From: "Julian K. Arni" Date: Mon, 25 Apr 2016 12:32:02 +0200 Subject: [PATCH] Add new predicates. * notAllowedContainsAllowHeader * getsHaveCacheControlHeader * headsHaveCacheControlHeader --- .../QuickCheck/Internal/HasGenRequest.hs | 4 + src/Servant/QuickCheck/Internal/Predicates.hs | 87 ++++++++++++++----- src/Servant/QuickCheck/Internal/QuickCheck.hs | 10 ++- test/Servant/QuickCheck/InternalSpec.hs | 22 +++-- 4 files changed, 94 insertions(+), 29 deletions(-) diff --git a/src/Servant/QuickCheck/Internal/HasGenRequest.hs b/src/Servant/QuickCheck/Internal/HasGenRequest.hs index b0ed6a8..078f953 100644 --- a/src/Servant/QuickCheck/Internal/HasGenRequest.hs +++ b/src/Servant/QuickCheck/Internal/HasGenRequest.hs @@ -130,3 +130,7 @@ instance (HasGenRequest a) => HasGenRequest (Vault :> a) where instance (HasGenRequest a) => HasGenRequest (WithNamedContext x y a) where genRequest _ = genRequest (Proxy :: Proxy a) + +-- TODO: Try logging in +instance (HasGenRequest a) => HasGenRequest (BasicAuth x y :> a) where + genRequest _ = genRequest (Proxy :: Proxy a) diff --git a/src/Servant/QuickCheck/Internal/Predicates.hs b/src/Servant/QuickCheck/Internal/Predicates.hs index b85c480..38a5389 100644 --- a/src/Servant/QuickCheck/Internal/Predicates.hs +++ b/src/Servant/QuickCheck/Internal/Predicates.hs @@ -87,15 +87,26 @@ getsHaveLastModifiedHeader -- __References__: -- -- * @Allow@ header: -notAllowedContainsAllowHeader :: ResponsePredicate Text Bool +-- * Status 405: +notAllowedContainsAllowHeader :: RequestPredicate Text Bool notAllowedContainsAllowHeader - = ResponsePredicate "notAllowedContainsAllowHeader" (\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) + = RequestPredicate + { reqPredName = name + , reqResps = \req mgr -> mapM (flip httpLbs mgr) + [ req { method = renderStdMethod m } + | m <- [minBound .. maxBound ] + , renderStdMethod m /= method req ] + , 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 @@ -104,28 +115,64 @@ notAllowedContainsAllowHeader -- -- This function checks that every *successful* response has a @Content-Type@ -- header that matches the @Accept@ header. -honoursAcceptHeader :: Predicate b Bool +-- +-- __References__: +-- +-- * @Accept@ header: +honoursAcceptHeader :: RequestPredicate b Bool 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 -- should not be cached, used @Cache-Control: no-cache@. -- --- This function checks that @GET@ responses have a valid @Cache-Control@ --- header. +-- This function checks that @GET@ responses have @Cache-Control@ header. +-- It does NOT currently check that the header is valid. -- --- References: RFC 7234 Section 5.2 --- https://tools.ietf.org/html/rfc7234#section-5.2 -getsHaveCacheControlHeader :: Predicate b Bool +-- __References__: +-- +-- * @Cache-Control@ header: +getsHaveCacheControlHeader :: RequestPredicate Text Bool 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. -headsHaveCacheControlHeader :: Predicate b Bool +-- | [__Best Practice__] +-- +-- Like 'getsHaveCacheControlHeader', but for @HEAD@ requests. +headsHaveCacheControlHeader :: RequestPredicate Text Bool 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 diff --git a/src/Servant/QuickCheck/Internal/QuickCheck.hs b/src/Servant/QuickCheck/Internal/QuickCheck.hs index 822c473..7b6e004 100644 --- a/src/Servant/QuickCheck/Internal/QuickCheck.hs +++ b/src/Servant/QuickCheck/Internal/QuickCheck.hs @@ -25,8 +25,14 @@ import Servant.QuickCheck.Internal.Equality -- then stop the application. withServantServer :: HasServer a '[] => Proxy a -> IO (Server a) -> (BaseUrl -> IO r) -> IO r -withServantServer api server t - = withApplication (return . serve api =<< server) $ \port -> +withServantServer api = withServantServerAndContext api EmptyContext + +-- | 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 "") -- | Check that the two servers running under the provided @BaseUrl@s behave diff --git a/test/Servant/QuickCheck/InternalSpec.hs b/test/Servant/QuickCheck/InternalSpec.hs index 41ccd31..7955094 100644 --- a/test/Servant/QuickCheck/InternalSpec.hs +++ b/test/Servant/QuickCheck/InternalSpec.hs @@ -24,8 +24,8 @@ serversEqualSpec :: Spec serversEqualSpec = describe "serversEqual" $ do it "considers equal servers equal" $ do - withServantServer api server $ \burl1 -> - withServantServer api server $ \burl2 -> do + withServantServerAndContext api ctx server $ \burl1 -> + withServantServerAndContext api ctx server $ \burl2 -> do serversEqual api burl1 burl2 args bodyEquality @@ -33,12 +33,17 @@ serverSatisfiesSpec :: Spec serverSatisfiesSpec = describe "serverSatisfies" $ do it "succeeds for true predicates" $ do - withServantServer api server $ \burl -> - serverSatisfies api burl args (not500 <%> mempty) + withServantServerAndContext api ctx server $ \burl -> + serverSatisfies api burl args (unauthorizedContainsWWWAuthenticate + <%> not500 + <%> mempty) it "fails for false predicates" $ do - withServantServer api server $ \burl -> - serverSatisfies api burl args (onlyJsonObjects <%> mempty) + withServantServerAndContext api ctx server $ \burl -> do + -- 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 = describe "HasGenRequest" $ do @@ -54,6 +59,7 @@ isComprehensiveSpec = describe "HasGenRequest" $ do type API = ReqBody '[JSON] String :> Post '[JSON] String :<|> Get '[JSON] Int + :<|> BasicAuth "some-realm" () :> Get '[JSON] () api :: Proxy API api = Proxy @@ -63,8 +69,10 @@ server = do mvar <- newMVar "" return $ (\x -> liftIO $ swapMVar mvar x) :<|> (liftIO $ readMVar mvar >>= return . length) + :<|> (const $ return ()) - +ctx :: Context '[BasicAuthCheck ()] +ctx = BasicAuthCheck (const . return $ NoSuchUser) :. EmptyContext ------------------------------------------------------------------------------ -- Utils ------------------------------------------------------------------------------