Fix merge conflicts with master

haskell-servant · erewok · Oct 21, 2017 · Oct 21, 2017 · Oct 21, 2017 · Oct 21, 2017
commit d4f6aa527252e74f20063efa9745409547399dc1
diff --git a/src/Servant/QuickCheck/Internal/Predicates.hs b/src/Servant/QuickCheck/Internal/Predicates.hs
@@ -121,12 +121,12 @@ createContainsValidLocation
      resp <- httpLbs req mgr
      if responseStatus resp == status201
          then case lookup "Location" $ responseHeaders resp of
-             Nothing -> throw $ PredicateFailure "createContainsValidLocation" req resp
+             Nothing -> throw $ PredicateFailure n req resp
              Just l  -> case parseRequest $ SBSC.unpack l of
-               Nothing -> throw $ PredicateFailure "createContainsValidLocation" req resp
+               Nothing -> throw $ PredicateFailure n req resp
                Just x  -> do
                  resp2 <- httpLbs x mgr
-                 status2XX (Just req) resp2 n
+                 status2XX req resp2 n
                  return [resp, resp2]
          else return [resp]
 
@@ -227,7 +227,7 @@ honoursAcceptHeader
           sacc  = fromMaybe "*/*" $ lookup "Accept" (requestHeaders req)
       if status100 < scode && scode < status300
         then if isJust $ sctype >>= \x -> matchAccept [x] sacc
-          then throw $ PredicateFailure "honoursAcceptHeader" (Just req) resp
+          then throw $ PredicateFailure "honoursAcceptHeader" req resp
           else return [resp]
         else return [resp]
 
@@ -341,6 +341,28 @@ unauthorizedContainsWWWAuthenticate
           throw $ PredicateFailure "unauthorizedContainsWWWAuthenticate" req resp
         else return ()
 
+
+-- | [__RFC Compliance__]
+--
+-- [An HTML] document will start with exactly this string: <!DOCTYPE html>
+--
+-- This function checks that HTML documents (those with `Content-Type: text/html...`)
+-- include a DOCTYPE declaration at the top. We do not enforce capital case for the string `DOCTYPE`.
+--
+-- __References__:
+--
+--  * HTML5 Doctype: <https://tools.ietf.org/html/rfc7992#section-6.1 RFC 7992 Section 6.1>
+-- /Since 0.3.0.0/
+htmlIncludesDoctype :: ResponsePredicate
+htmlIncludesDoctype
+  = ResponsePredicate $ \req resp ->
+      if hasValidHeader "Content-Type" (SBS.isPrefixOf . foldCase $ "text/html") resp
+        then do
+            let htmlContent = foldCase . LBS.take 20 $ responseBody resp
+            unless (LBS.isPrefixOf (foldCase "<!doctype html>") htmlContent) $
+              throw $ PredicateFailure "htmlIncludesDoctype" req resp
+        else return ()
+
 -- * Predicate logic
 
 -- The idea with all this footwork is to not waste any requests. Rather than
@@ -425,8 +447,8 @@ isRFC822Date s
     Nothing -> False
     Just (_ :: UTCTime) -> True
 
-status2XX :: Monad m => Maybe Request -> Response LBS.ByteString -> T.Text -> m ()
-status2XX mreq resp t
+status2XX :: Monad m => Request -> Response LBS.ByteString -> T.Text -> m ()
+status2XX req resp t
   | status200 <= responseStatus resp && responseStatus resp < status300
   = return ()
-  | otherwise = throw $ PredicateFailure t mreq resp
+  | otherwise = throw $ PredicateFailure t req resp
diff --git a/test/Servant/QuickCheck/InternalSpec.hs b/test/Servant/QuickCheck/InternalSpec.hs
@@ -53,6 +53,7 @@ spec = do
   queryFlagsSpec
   deepPathSpec
   authServerCheck
+  htmlDocTypesSpec
   unbiasedGenerationSpec
 
 serversEqualSpec :: Spec
@@ -203,7 +204,6 @@ queryFlagsSpec = describe "QueryFlags" $ do
         qs = C.unpack $ queryString req
     qs `shouldBe` "one&two"
 
-
 authServerCheck :: Spec
 authServerCheck = describe "authenticate endpoints" $ do
 
@@ -215,6 +215,25 @@ authServerCheck = describe "authenticate endpoints" $ do
 
 
 -- Large API Randomness Testing Helper
+htmlDocTypesSpec :: Spec
+htmlDocTypesSpec = describe "HtmlDocTypes" $ do
+
+    it "fails HTML without doctype correctly" $ do
+      err <- withServantServerAndContext docTypeApi ctx noDocTypeServer $ \burl -> do
+        evalExample $ serverSatisfies docTypeApi burl args
+          (htmlIncludesDoctype <%> mempty)
+      show err `shouldContain` "htmlIncludesDoctype"
+
+    it "passes HTML with a doctype at start" $ do
+      withServantServerAndContext docTypeApi ctx docTypeServer $ \burl ->
+        serverSatisfies docTypeApi burl args (htmlIncludesDoctype <%> mempty)
+
+    it "accepts json endpoints and passes over them in silence" $ do
+      withServantServerAndContext api ctx server $ \burl -> do
+        serverSatisfies (Proxy :: Proxy (Get '[JSON] Int)) burl args
+          (htmlIncludesDoctype <%> mempty)
+
+
 makeRandomRequest :: Proxy LargeAPI -> BaseUrl -> IO Integer
 makeRandomRequest large burl = do
   req <- generate $ runGenRequest large
@@ -288,7 +307,19 @@ server500fail = return $ throwError $ err500 { errBody = "BOOM!" }
 authFailServer :: IO (Server API2)
 authFailServer = return $ throwError $ err401 { errBody = "Login failure but missing header"}
 
--- Large API for testing the random generator's randomness
+-- With Doctypes
+type HtmlDoctype = Get '[HTML] Blaze.Html
+
+docTypeApi :: Proxy HtmlDoctype
+docTypeApi = Proxy
+
+docTypeServer :: IO (Server HtmlDoctype)
+docTypeServer = pure $ pure $ Blaze5.docTypeHtml $ Blaze5.span "Hello Test!"
+
+noDocTypeServer :: IO (Server HtmlDoctype)
+noDocTypeServer = pure $ pure $ Blaze.text "Hello Test!"
+
+-- Api for unbiased generation of requests tests
 largeApi :: Proxy LargeAPI
 largeApi = Proxy