Add new predicates.

* notAllowedContainsAllowHeader
    * getsHaveCacheControlHeader
    * headsHaveCacheControlHeader

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)

src/Servant/QuickCheck/Internal/Predicates.hs

@@ -87,15 +87,26 @@ getsHaveLastModifiedHeader
 -- __References__:
 --
 --   * @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
-  = 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: <https://www.w3.org/Protocols/rfc2616/rfc2616-sec14.html RFC 2616 Section 14.1>
+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: <https://tools.ietf.org/html/rfc7234#section-5.2 RFC 7234 Section 5.2>
+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

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

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
 ------------------------------------------------------------------------------