From f36f544ee6a292a1dfffa898004d76e3dddddb97 Mon Sep 17 00:00:00 2001
From: "Julian K. Arni" <jkarni@gmail.com>
Date: Mon, 3 Oct 2016 15:39:46 +0200
Subject: [PATCH] Add predicate getsHaveLastModifiedHeader.

---
 .gitignore                                    |  1 +
 servant-quickcheck.cabal                      |  1 +
 src/Servant/QuickCheck/Internal/Predicates.hs | 47 +++++++++++++++++--
 3 files changed, 45 insertions(+), 4 deletions(-)

diff --git a/.gitignore b/.gitignore
index 09686b7..10c5e0c 100644
--- a/.gitignore
+++ b/.gitignore
@@ -3,3 +3,4 @@ scripts/
 samples/
 test-servers/
 /doc/
+.stack-work/
diff --git a/servant-quickcheck.cabal b/servant-quickcheck.cabal
index 5fa56fd..cf83653 100644
--- a/servant-quickcheck.cabal
+++ b/servant-quickcheck.cabal
@@ -52,6 +52,7 @@ library
                      , string-conversions > 0.3 && < 0.5
                      , temporary == 1.2.*
                      , text == 1.*
+                     , time == 1.5.*
                      , warp >= 3.2.4 && < 3.3
 
   hs-source-dirs:      src
diff --git a/src/Servant/QuickCheck/Internal/Predicates.hs b/src/Servant/QuickCheck/Internal/Predicates.hs
index 1954011..2832364 100644
--- a/src/Servant/QuickCheck/Internal/Predicates.hs
+++ b/src/Servant/QuickCheck/Internal/Predicates.hs
@@ -11,6 +11,8 @@ import           Data.Either           (isRight)
 import           Data.List.Split       (wordsBy)
 import           Data.Maybe            (fromMaybe, isJust)
 import           Data.Monoid           ((<>))
+import           Data.Time             (parseTimeM, defaultTimeLocale,
+                                        rfc822DateFormat, UTCTime)
 import           GHC.Generics          (Generic)
 import           Network.HTTP.Client   (Manager, Request, Response, httpLbs,
                                         method, requestHeaders, responseBody,
@@ -100,12 +102,43 @@ createContainsValidLocation
                  return [resp, resp2]
          else return [resp]
 
-{-
-getsHaveLastModifiedHeader :: ResponsePredicate
+-- | [__Optional__]
+--
+-- The @Last-Modified@ header represents the time a resource was last
+-- modified. It is used to drive caching and conditional requests.
+--
+-- When using this mechanism, the server adds the @Last-Modified@ header to
+-- responses. Clients may then make requests with the @If-Modified-Since@
+-- header to conditionally request resources. If the resource has not
+-- changed since that date, the server responds with a status code of 304
+-- (@Not Modified@) without a response body.
+--
+-- The @Last-Modified@ header can also be used in conjunction with the
+-- @If-Unmodified-Since@ header to drive optimistic concurrency.
+--
+-- The @Last-Modified@ date must be in RFC 822 format.
+--
+-- __References__:
+--
+--   * 304 Not Modified: <https://tools.ietf.org/html/rfc7232#section-4.1 RFC 7232 Section 4.1>
+--   * Last-Modified header: <https://tools.ietf.org/html/rfc7232#section-2.2 RFC 7232 Section 2.2>
+--   * If-Modified-Since header: <https://tools.ietf.org/html/rfc7232#section-3.3 RFC 7232 Section 3.3>
+--   * If-Unmodified-Since header: <https://tools.ietf.org/html/rfc7232#section-3.4 RFC 7232 Section 3.4>
+--   * Date format: <https://tools.ietf.org/html/rfc2616#section-3.3 RFC 2616 Section 3.3>
+--
+-- #SINCECURRENT#
+getsHaveLastModifiedHeader :: RequestPredicate
 getsHaveLastModifiedHeader
-  = ResponsePredicate "getsHaveLastModifiedHeader" (\resp ->
+  = RequestPredicate $ \req mgr ->
+     if (method req == methodGet)
+      then do
+        resp <- httpLbs req mgr
+        unless (hasValidHeader "Last-Modified" isRFC822Date resp) $ do
+          throw $ PredicateFailure "getsHaveLastModifiedHeader" (Just req) resp
+        return [resp]
+      else return []
+
 
--}
 
 -- | [__RFC Compliance__]
 --
@@ -354,6 +387,12 @@ hasValidHeader hdr p r = case lookup (mk hdr) (responseHeaders r) of
   Nothing -> False
   Just v  -> p v
 
+isRFC822Date :: SBS.ByteString -> Bool
+isRFC822Date s
+  = case parseTimeM True defaultTimeLocale rfc822DateFormat (SBSC.unpack s) of
+    Nothing -> False
+    Just (_ :: UTCTime) -> True
+
 status2XX :: Monad m => Response b -> String -> m ()
 status2XX r t
   | status200 <= responseStatus r && responseStatus r < status300