module Servant.QuickCheck.Internal.Predicates where

import           Control.Exception     (catch, throw)
import           Control.Monad         (liftM2, unless, when)
import           Data.Aeson            (Object, decode)
import           Data.Bifunctor        (first)
import qualified Data.ByteString       as SBS
import qualified Data.ByteString.Char8 as SBSC
import qualified Data.ByteString.Lazy  as LBS
import           Data.CaseInsensitive  (foldCase, foldedCase, mk)
import           Data.Either           (isRight)
import           Data.List.Split       (wordsBy)
import           Data.Maybe            (fromMaybe, isJust)
import qualified Data.Text             as T
import           Data.Time             (UTCTime, defaultTimeLocale, parseTimeM,
                                        rfc822DateFormat)
import           GHC.Generics          (Generic)
import           Network.HTTP.Client   (Manager, Request, Response, httpLbs,
                                        method, parseRequest, requestHeaders,
                                        responseBody, responseHeaders,
                                        responseStatus)
import           Network.HTTP.Media    (matchAccept)
import           Network.HTTP.Types    (methodGet, methodHead, parseMethod,
                                        renderStdMethod, status100, status200,
                                        status201, status300, status401,
                                        status405, status500)
import           Prelude.Compat
import           System.Clock          (Clock (Monotonic), diffTimeSpec,
                                        getTime, toNanoSecs)

import Servant.QuickCheck.Internal.ErrorTypes


-- | [__Best Practice__]
--
-- @500 Internal Server Error@ should be avoided - it may represent some
-- issue with the application code, and it moreover gives the client little
-- indication of how to proceed or what went wrong.
--
-- This function checks that the response code is not 500.
--
-- /Since 0.0.0.0/
not500 :: ResponsePredicate
not500 :: ResponsePredicate
not500 = (Response ByteString -> IO ()) -> ResponsePredicate
ResponsePredicate ((Response ByteString -> IO ()) -> ResponsePredicate)
-> (Response ByteString -> IO ()) -> ResponsePredicate
forall a b. (a -> b) -> a -> b
$ \Response ByteString
resp ->
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Response ByteString -> Status
forall body. Response body -> Status
responseStatus Response ByteString
resp Status -> Status -> Bool
forall a. Eq a => a -> a -> Bool
== Status
status500) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ PredicateFailure -> IO ()
forall a e. Exception e => e -> a
throw (PredicateFailure -> IO ()) -> PredicateFailure -> IO ()
forall a b. (a -> b) -> a -> b
$ Text -> Maybe Request -> Response ByteString -> PredicateFailure
PredicateFailure Text
"not500" Maybe Request
forall a. Maybe a
Nothing Response ByteString
resp

-- | [__Optional__]
--
-- This function checks that the response from the server does not take longer
-- than the specified number of nanoseconds.
--
-- /Since 0.0.2.1/
notLongerThan :: Integer -> RequestPredicate
notLongerThan :: Integer -> RequestPredicate
notLongerThan Integer
maxAllowed
  = (Request -> Manager -> IO [Response ByteString])
-> RequestPredicate
RequestPredicate ((Request -> Manager -> IO [Response ByteString])
 -> RequestPredicate)
-> (Request -> Manager -> IO [Response ByteString])
-> RequestPredicate
forall a b. (a -> b) -> a -> b
$ \Request
req Manager
mgr -> do
     TimeSpec
start <- Clock -> IO TimeSpec
getTime Clock
Monotonic
     Response ByteString
resp <- Request -> Manager -> IO (Response ByteString)
httpLbs Request
req Manager
mgr
     TimeSpec
end <- Clock -> IO TimeSpec
getTime Clock
Monotonic
     Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (TimeSpec -> Integer
toNanoSecs (TimeSpec
end TimeSpec -> TimeSpec -> TimeSpec
`diffTimeSpec` TimeSpec
start) Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
> Integer
maxAllowed) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
       PredicateFailure -> IO ()
forall a e. Exception e => e -> a
throw (PredicateFailure -> IO ()) -> PredicateFailure -> IO ()
forall a b. (a -> b) -> a -> b
$ Text -> Maybe Request -> Response ByteString -> PredicateFailure
PredicateFailure Text
"notLongerThan" (Request -> Maybe Request
forall a. a -> Maybe a
Just Request
req) Response ByteString
resp
     [Response ByteString] -> IO [Response ByteString]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return []

-- | [__Best Practice__]
--
-- Returning anything other than an object when returning JSON is considered
-- bad practice, as:
--
--   (1) it is hard to modify the returned value while maintaining backwards
--   compatibility
--   (2) many older tools do not support top-level arrays
--   (3) whether top-level numbers, booleans, or strings are valid JSON depends
--   on what RFC you're going by
--   (4) there are security issues with top-level arrays
--
-- This function checks that any @application/json@ responses only return JSON
-- objects (and not arrays, strings, numbers, or booleans) at the top level.
--
-- __References__:
--
--   * JSON Grammar: <https://tools.ietf.org/html/rfc7159#section-2 RFC 7159 Section 2>
--   * JSON Grammar: <https://tools.ietf.org/html/rfc4627#section-2 RFC 4627 Section 2>
--
-- /Since 0.0.0.0/
onlyJsonObjects :: ResponsePredicate
onlyJsonObjects :: ResponsePredicate
onlyJsonObjects
  = (Response ByteString -> IO ()) -> ResponsePredicate
ResponsePredicate (\Response ByteString
resp -> do
    case ByteString -> [(ByteString, ByteString)] -> Maybe ByteString
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup ByteString
"content-type" ((HeaderName -> ByteString)
-> (HeaderName, ByteString) -> (ByteString, ByteString)
forall a b c. (a -> b) -> (a, c) -> (b, c)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first HeaderName -> ByteString
forall s. CI s -> s
foldedCase ((HeaderName, ByteString) -> (ByteString, ByteString))
-> [(HeaderName, ByteString)] -> [(ByteString, ByteString)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Response ByteString -> [(HeaderName, ByteString)]
forall body. Response body -> [(HeaderName, ByteString)]
responseHeaders Response ByteString
resp) of
      Maybe ByteString
Nothing    -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      Just ByteString
ctype -> Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ByteString
"application/json" ByteString -> ByteString -> Bool
`SBS.isPrefixOf` ByteString
ctype) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
        case (ByteString -> Maybe Object
forall a. FromJSON a => ByteString -> Maybe a
decode (Response ByteString -> ByteString
forall body. Response body -> body
responseBody Response ByteString
resp) :: Maybe Object) of
          Maybe Object
Nothing -> PredicateFailure -> IO ()
forall a e. Exception e => e -> a
throw (PredicateFailure -> IO ()) -> PredicateFailure -> IO ()
forall a b. (a -> b) -> a -> b
$ Text -> Maybe Request -> Response ByteString -> PredicateFailure
PredicateFailure Text
"onlyJsonObjects" Maybe Request
forall a. Maybe a
Nothing Response ByteString
resp
          Just Object
_  -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ())

-- | __Optional__
--
-- When creating a new resource, it is good practice to provide a @Location@
-- header with a link to the created resource.
--
-- This function checks that every @201 Created@ response contains a @Location@
-- header, and that the link in it responds with a 2XX response code to @GET@
-- requests.
--
-- This is considered optional because other means of linking to the resource
-- (e.g. via the response body) are also acceptable; linking to the resource in
-- some way is considered best practice.
--
-- __References__:
--
--   * 201 Created: <https://tools.ietf.org/html/rfc7231#section-6.3.2 RFC 7231 Section 6.3.2>
--   * Location header: <https://tools.ietf.org/html/rfc7231#section-7.1.2 RFC 7231 Section 7.1.2>
--
-- /Since 0.0.0.0/
createContainsValidLocation :: RequestPredicate
createContainsValidLocation :: RequestPredicate
createContainsValidLocation
  = (Request -> Manager -> IO [Response ByteString])
-> RequestPredicate
RequestPredicate ((Request -> Manager -> IO [Response ByteString])
 -> RequestPredicate)
-> (Request -> Manager -> IO [Response ByteString])
-> RequestPredicate
forall a b. (a -> b) -> a -> b
$ \Request
req Manager
mgr -> do
     let n :: Text
n = Text
"createContainsValidLocation"
     Response ByteString
resp <- Request -> Manager -> IO (Response ByteString)
httpLbs Request
req Manager
mgr
     if Response ByteString -> Status
forall body. Response body -> Status
responseStatus Response ByteString
resp Status -> Status -> Bool
forall a. Eq a => a -> a -> Bool
== Status
status201
         then case HeaderName -> [(HeaderName, ByteString)] -> Maybe ByteString
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup HeaderName
"Location" ([(HeaderName, ByteString)] -> Maybe ByteString)
-> [(HeaderName, ByteString)] -> Maybe ByteString
forall a b. (a -> b) -> a -> b
$ Response ByteString -> [(HeaderName, ByteString)]
forall body. Response body -> [(HeaderName, ByteString)]
responseHeaders Response ByteString
resp of
             Maybe ByteString
Nothing -> PredicateFailure -> IO [Response ByteString]
forall a e. Exception e => e -> a
throw (PredicateFailure -> IO [Response ByteString])
-> PredicateFailure -> IO [Response ByteString]
forall a b. (a -> b) -> a -> b
$ Text -> Maybe Request -> Response ByteString -> PredicateFailure
PredicateFailure Text
n (Request -> Maybe Request
forall a. a -> Maybe a
Just Request
req) Response ByteString
resp
             Just ByteString
l  -> case String -> Maybe Request
forall (m :: * -> *). MonadThrow m => String -> m Request
parseRequest (String -> Maybe Request) -> String -> Maybe Request
forall a b. (a -> b) -> a -> b
$ ByteString -> String
SBSC.unpack ByteString
l of
               Maybe Request
Nothing -> PredicateFailure -> IO [Response ByteString]
forall a e. Exception e => e -> a
throw (PredicateFailure -> IO [Response ByteString])
-> PredicateFailure -> IO [Response ByteString]
forall a b. (a -> b) -> a -> b
$ Text -> Maybe Request -> Response ByteString -> PredicateFailure
PredicateFailure Text
n (Request -> Maybe Request
forall a. a -> Maybe a
Just Request
req) Response ByteString
resp
               Just Request
x  -> do
                 Response ByteString
resp2 <- Request -> Manager -> IO (Response ByteString)
httpLbs Request
x Manager
mgr
                 Maybe Request -> Response ByteString -> Text -> IO ()
forall (m :: * -> *).
Monad m =>
Maybe Request -> Response ByteString -> Text -> m ()
status2XX (Request -> Maybe Request
forall a. a -> Maybe a
Just Request
req) Response ByteString
resp2 Text
n
                 [Response ByteString] -> IO [Response ByteString]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [Response ByteString
resp, Response ByteString
resp2]
         else [Response ByteString] -> IO [Response ByteString]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [Response ByteString
resp]

-- | [__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>
--
-- /Since 0.0.2.1/
getsHaveLastModifiedHeader :: RequestPredicate
getsHaveLastModifiedHeader :: RequestPredicate
getsHaveLastModifiedHeader
  = (Request -> Manager -> IO [Response ByteString])
-> RequestPredicate
RequestPredicate ((Request -> Manager -> IO [Response ByteString])
 -> RequestPredicate)
-> (Request -> Manager -> IO [Response ByteString])
-> RequestPredicate
forall a b. (a -> b) -> a -> b
$ \Request
req Manager
mgr ->
     if Request -> ByteString
method Request
req ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
methodGet
      then do
        Response ByteString
resp <- Request -> Manager -> IO (Response ByteString)
httpLbs Request
req Manager
mgr
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (ByteString -> (ByteString -> Bool) -> Response ByteString -> Bool
forall b. ByteString -> (ByteString -> Bool) -> Response b -> Bool
hasValidHeader ByteString
"Last-Modified" ByteString -> Bool
isRFC822Date Response ByteString
resp) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
          PredicateFailure -> IO ()
forall a e. Exception e => e -> a
throw (PredicateFailure -> IO ()) -> PredicateFailure -> IO ()
forall a b. (a -> b) -> a -> b
$ Text -> Maybe Request -> Response ByteString -> PredicateFailure
PredicateFailure Text
"getsHaveLastModifiedHeader" (Request -> Maybe Request
forall a. a -> Maybe a
Just Request
req) Response ByteString
resp
        [Response ByteString] -> IO [Response ByteString]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [Response ByteString
resp]
      else [Response ByteString] -> IO [Response ByteString]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return []



-- | [__RFC Compliance__]
--
-- When an HTTP request has a method that is not allowed,
-- a 405 response should be returned. Additionally, it is good practice to
-- return an @Allow@
-- header with the list of allowed methods.
--
-- This function checks that every @405 Method Not Allowed@ response contains
-- an @Allow@ header with a list of standard HTTP methods.
--
-- Note that 'servant' itself does not currently set the @Allow@ headers.
--
-- __References__:
--
--   * @Allow@ header: <https://www.w3.org/Protocols/rfc2616/rfc2616-sec14.html RFC 2616 Section 14.7>
--   * Status 405: <https://www.w3.org/Protocols/rfc2616/rfc2616-sec10.html RFC 2616 Section 10.4.6>
--   * Servant Allow header issue: <https://github.com/haskell-servant/servant/issues/489 Issue #489>
--
-- /Since 0.0.0.0/
notAllowedContainsAllowHeader :: RequestPredicate
notAllowedContainsAllowHeader :: RequestPredicate
notAllowedContainsAllowHeader
  = (Request -> Manager -> IO [Response ByteString])
-> RequestPredicate
RequestPredicate ((Request -> Manager -> IO [Response ByteString])
 -> RequestPredicate)
-> (Request -> Manager -> IO [Response ByteString])
-> RequestPredicate
forall a b. (a -> b) -> a -> b
$ \Request
req Manager
mgr -> do
      let reqs :: [Request]
reqs = [ Request
req { method = renderStdMethod m } | StdMethod
m <- [StdMethod
forall a. Bounded a => a
minBound .. StdMethod
forall a. Bounded a => a
maxBound]
                                                      , StdMethod -> ByteString
renderStdMethod StdMethod
m ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
/= Request -> ByteString
method Request
req ]
      [Response ByteString]
resp <- (Request -> IO (Response ByteString))
-> [Request] -> IO [Response ByteString]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (Request -> Manager -> IO (Response ByteString)
`httpLbs` Manager
mgr) [Request]
reqs

      case ((Request, Response ByteString) -> Bool)
-> [(Request, Response ByteString)]
-> [(Request, Response ByteString)]
forall a. (a -> Bool) -> [a] -> [a]
filter (Request, Response ByteString) -> Bool
forall {a} {b}. (a, Response b) -> Bool
pred' ([Request]
-> [Response ByteString] -> [(Request, Response ByteString)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Request]
reqs [Response ByteString]
resp) of
        ((Request, Response ByteString)
x:[(Request, Response ByteString)]
_) -> PredicateFailure -> IO [Response ByteString]
forall a e. Exception e => e -> a
throw (PredicateFailure -> IO [Response ByteString])
-> PredicateFailure -> IO [Response ByteString]
forall a b. (a -> b) -> a -> b
$ Text -> Maybe Request -> Response ByteString -> PredicateFailure
PredicateFailure Text
"notAllowedContainsAllowHeader" (Request -> Maybe Request
forall a. a -> Maybe a
Just (Request -> Maybe Request) -> Request -> Maybe Request
forall a b. (a -> b) -> a -> b
$ (Request, Response ByteString) -> Request
forall a b. (a, b) -> a
fst (Request, Response ByteString)
x) ((Request, Response ByteString) -> Response ByteString
forall a b. (a, b) -> b
snd (Request, Response ByteString)
x)
        []     -> [Response ByteString] -> IO [Response ByteString]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [Response ByteString]
resp
    where
      pred' :: (a, Response b) -> Bool
pred' (a
_, Response b
resp) = Response b -> Status
forall body. Response body -> Status
responseStatus Response b
resp Status -> Status -> Bool
forall a. Eq a => a -> a -> Bool
== Status
status405 Bool -> Bool -> Bool
&& Bool -> Bool
not (ByteString -> (ByteString -> Bool) -> Response b -> Bool
forall b. ByteString -> (ByteString -> Bool) -> Response b -> Bool
hasValidHeader ByteString
"Allow" ByteString -> Bool
go Response b
resp)
        where
          go :: ByteString -> Bool
go ByteString
x = (String -> Bool) -> [String] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Either ByteString StdMethod -> Bool
forall a b. Either a b -> Bool
isRight (Either ByteString StdMethod -> Bool)
-> (String -> Either ByteString StdMethod) -> String -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Either ByteString StdMethod
parseMethod (ByteString -> Either ByteString StdMethod)
-> (String -> ByteString) -> String -> Either ByteString StdMethod
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ByteString
SBSC.pack)
               ([String] -> Bool) -> [String] -> Bool
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> String -> [String]
forall a. (a -> Bool) -> [a] -> [[a]]
wordsBy (Char -> String -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` (String
", " :: [Char])) (ByteString -> String
SBSC.unpack ByteString
x)


-- | [__RFC Compliance__]
--
-- When a request contains an @Accept@ header, the server must either return
-- content in one of the requested representations, or respond with @406 Not
-- Acceptable@.
--
-- This function checks that every *successful* response has a @Content-Type@
-- header that matches the @Accept@ header. It does *not* check that the server
-- matches the quality descriptions of the @Accept@ header correctly.
--
-- __References__:
--
--   * @Accept@ header: <https://www.w3.org/Protocols/rfc2616/rfc2616-sec14.html RFC 2616 Section 14.1>
--
-- /Since 0.0.0.0/
honoursAcceptHeader :: RequestPredicate
honoursAcceptHeader :: RequestPredicate
honoursAcceptHeader
  = (Request -> Manager -> IO [Response ByteString])
-> RequestPredicate
RequestPredicate ((Request -> Manager -> IO [Response ByteString])
 -> RequestPredicate)
-> (Request -> Manager -> IO [Response ByteString])
-> RequestPredicate
forall a b. (a -> b) -> a -> b
$ \Request
req Manager
mgr -> do
      Response ByteString
resp <- Request -> Manager -> IO (Response ByteString)
httpLbs Request
req Manager
mgr
      let scode :: Status
scode = Response ByteString -> Status
forall body. Response body -> Status
responseStatus Response ByteString
resp
          sctype :: Maybe ByteString
sctype = HeaderName -> [(HeaderName, ByteString)] -> Maybe ByteString
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup HeaderName
"Content-Type" ([(HeaderName, ByteString)] -> Maybe ByteString)
-> [(HeaderName, ByteString)] -> Maybe ByteString
forall a b. (a -> b) -> a -> b
$ Response ByteString -> [(HeaderName, ByteString)]
forall body. Response body -> [(HeaderName, ByteString)]
responseHeaders Response ByteString
resp
          sacc :: ByteString
sacc  = ByteString -> Maybe ByteString -> ByteString
forall a. a -> Maybe a -> a
fromMaybe ByteString
"*/*" (Maybe ByteString -> ByteString) -> Maybe ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ HeaderName -> [(HeaderName, ByteString)] -> Maybe ByteString
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup HeaderName
"Accept" (Request -> [(HeaderName, ByteString)]
requestHeaders Request
req)
      (if (Status
status100 Status -> Status -> Bool
forall a. Ord a => a -> a -> Bool
< Status
scode Bool -> Bool -> Bool
&& Status
scode Status -> Status -> Bool
forall a. Ord a => a -> a -> Bool
< Status
status300) Bool -> Bool -> Bool
&& Maybe ByteString -> Bool
forall a. Maybe a -> Bool
isJust (Maybe ByteString
sctype Maybe ByteString
-> (ByteString -> Maybe ByteString) -> Maybe ByteString
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \ByteString
x -> [ByteString] -> ByteString -> Maybe ByteString
forall a. Accept a => [a] -> ByteString -> Maybe a
matchAccept [ByteString
x] ByteString
sacc)
        then PredicateFailure -> IO [Response ByteString]
forall a e. Exception e => e -> a
throw (PredicateFailure -> IO [Response ByteString])
-> PredicateFailure -> IO [Response ByteString]
forall a b. (a -> b) -> a -> b
$ Text -> Maybe Request -> Response ByteString -> PredicateFailure
PredicateFailure Text
"honoursAcceptHeader" (Request -> Maybe Request
forall a. a -> Maybe a
Just Request
req) Response ByteString
resp
        else [Response ByteString] -> IO [Response ByteString]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [Response ByteString
resp])


-- | [__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 @Cache-Control@ header.
-- It does NOT currently check that the header is valid.
--
-- __References__:
--
--   * @Cache-Control@ header: <https://tools.ietf.org/html/rfc7234#section-5.2 RFC 7234 Section 5.2>
--
-- /Since 0.0.0.0/
getsHaveCacheControlHeader :: RequestPredicate
getsHaveCacheControlHeader :: RequestPredicate
getsHaveCacheControlHeader
  = (Request -> Manager -> IO [Response ByteString])
-> RequestPredicate
RequestPredicate ((Request -> Manager -> IO [Response ByteString])
 -> RequestPredicate)
-> (Request -> Manager -> IO [Response ByteString])
-> RequestPredicate
forall a b. (a -> b) -> a -> b
$ \Request
req Manager
mgr ->
     if Request -> ByteString
method Request
req ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
methodGet
      then do
        Response ByteString
resp <- Request -> Manager -> IO (Response ByteString)
httpLbs Request
req Manager
mgr
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (ByteString -> (ByteString -> Bool) -> Response ByteString -> Bool
forall b. ByteString -> (ByteString -> Bool) -> Response b -> Bool
hasValidHeader ByteString
"Cache-Control" (Bool -> ByteString -> Bool
forall a b. a -> b -> a
const Bool
True) Response ByteString
resp) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
          PredicateFailure -> IO ()
forall a e. Exception e => e -> a
throw (PredicateFailure -> IO ()) -> PredicateFailure -> IO ()
forall a b. (a -> b) -> a -> b
$ Text -> Maybe Request -> Response ByteString -> PredicateFailure
PredicateFailure Text
"getsHaveCacheControlHeader" (Request -> Maybe Request
forall a. a -> Maybe a
Just Request
req) Response ByteString
resp
        [Response ByteString] -> IO [Response ByteString]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [Response ByteString
resp]
      else [Response ByteString] -> IO [Response ByteString]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return []

-- | [__Best Practice__]
--
-- Like 'getsHaveCacheControlHeader', but for @HEAD@ requests.
--
-- /Since 0.0.0.0/
headsHaveCacheControlHeader :: RequestPredicate
headsHaveCacheControlHeader :: RequestPredicate
headsHaveCacheControlHeader
  = (Request -> Manager -> IO [Response ByteString])
-> RequestPredicate
RequestPredicate ((Request -> Manager -> IO [Response ByteString])
 -> RequestPredicate)
-> (Request -> Manager -> IO [Response ByteString])
-> RequestPredicate
forall a b. (a -> b) -> a -> b
$ \Request
req Manager
mgr ->
     if Request -> ByteString
method Request
req ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
methodHead
       then do
         Response ByteString
resp <- Request -> Manager -> IO (Response ByteString)
httpLbs Request
req Manager
mgr
         Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (ByteString -> (ByteString -> Bool) -> Response ByteString -> Bool
forall b. ByteString -> (ByteString -> Bool) -> Response b -> Bool
hasValidHeader ByteString
"Cache-Control" (Bool -> ByteString -> Bool
forall a b. a -> b -> a
const Bool
True) Response ByteString
resp) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
           PredicateFailure -> IO ()
forall a e. Exception e => e -> a
throw (PredicateFailure -> IO ()) -> PredicateFailure -> IO ()
forall a b. (a -> b) -> a -> b
$ Text -> Maybe Request -> Response ByteString -> PredicateFailure
PredicateFailure Text
"headsHaveCacheControlHeader" (Request -> Maybe Request
forall a. a -> Maybe a
Just Request
req) Response ByteString
resp
         [Response ByteString] -> IO [Response ByteString]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [Response ByteString
resp]
       else [Response ByteString] -> IO [Response ByteString]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return []
{-
-- |
--
-- If the original request modifies the resource, this function makes two
-- requests:
--
--   (1) Once, with the original request and a future date as the
--   @If-Unmodified-Since@, which is expected to succeed.
--   (2) Then with the original request again, with a @If-Unmodified-Since@
--   safely in the past. Since presumably the representation has been changed
--   recently (by the first request), this is expected to fail with @412
--   Precondition Failure@.
--
-- Note that the heuristic used to guess whether the original request modifies
-- a resource is simply whether the method is @PUT@ or @PATCH@, which may be
-- incorrect in certain circumstances.
supportsIfUnmodifiedSince :: Predicate b Bool
supportsIfUnmodifiedSince
  = ResponsePredicate "supportsIfUnmodifiedSince" _

-- | @OPTIONS@ responses should contain an @Allow@ header with the list of
-- allowed methods.
--
-- If a request is an @OPTIONS@ request, and if the response is a successful
-- one, this function checks the response for an @Allow@ header. It fails if:
--
--   (1) There is no @Allow@ header
--   (2) The @Allow@ header does not have standard HTTP methods in the correct
--   format
--   (3) Making a request to the same URL with one of those methods results in
--   a 404 or 405.
optionsContainsValidAllow :: Predicate b Bool
optionsContainsValidAllow
  = ResponsePredicate "optionsContainsValidAllow" _

-- | Link headers are a standardized way of presenting links that may be
-- relevant to a client.
--
-- This function checks that any @Link@ headers have values in the correct
-- format.
--
-- __References__:
--
--   * <https://tools.ietf.org/html/rfc5988 RFC 5988 Section 5>
linkHeadersAreValid :: Predicate b Bool
linkHeadersAreValid
  = ResponsePredicate "linkHeadersAreValid" _

-}
-- | [__RFC Compliance__]
--
-- Any @401 Unauthorized@ response must include a @WWW-Authenticate@ header.
--
-- This function checks that, if a response has status code 401, it contains a
-- @WWW-Authenticate@ header.
--
-- __References__:
--
--   * @WWW-Authenticate@ header: <https://tools.ietf.org/html/rfc7235#section-4.1 RFC 7235 Section 4.1>
--
-- /Since 0.0.0.0/
unauthorizedContainsWWWAuthenticate :: ResponsePredicate
unauthorizedContainsWWWAuthenticate :: ResponsePredicate
unauthorizedContainsWWWAuthenticate
  = (Response ByteString -> IO ()) -> ResponsePredicate
ResponsePredicate ((Response ByteString -> IO ()) -> ResponsePredicate)
-> (Response ByteString -> IO ()) -> ResponsePredicate
forall a b. (a -> b) -> a -> b
$ \Response ByteString
resp ->
      Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Response ByteString -> Status
forall body. Response body -> Status
responseStatus Response ByteString
resp Status -> Status -> Bool
forall a. Eq a => a -> a -> Bool
== Status
status401) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (ByteString -> (ByteString -> Bool) -> Response ByteString -> Bool
forall b. ByteString -> (ByteString -> Bool) -> Response b -> Bool
hasValidHeader ByteString
"WWW-Authenticate" (Bool -> ByteString -> Bool
forall a b. a -> b -> a
const Bool
True) Response ByteString
resp) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
          PredicateFailure -> IO ()
forall a e. Exception e => e -> a
throw (PredicateFailure -> IO ()) -> PredicateFailure -> IO ()
forall a b. (a -> b) -> a -> b
$ Text -> Maybe Request -> Response ByteString -> PredicateFailure
PredicateFailure Text
"unauthorizedContainsWWWAuthenticate" Maybe Request
forall a. Maybe a
Nothing Response ByteString
resp


-- | [__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
htmlIncludesDoctype
  = (Response ByteString -> IO ()) -> ResponsePredicate
ResponsePredicate ((Response ByteString -> IO ()) -> ResponsePredicate)
-> (Response ByteString -> IO ()) -> ResponsePredicate
forall a b. (a -> b) -> a -> b
$ \Response ByteString
resp ->
      Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ByteString -> (ByteString -> Bool) -> Response ByteString -> Bool
forall b. ByteString -> (ByteString -> Bool) -> Response b -> Bool
hasValidHeader ByteString
"Content-Type" (ByteString -> ByteString -> Bool
SBS.isPrefixOf (ByteString -> ByteString -> Bool)
-> (ByteString -> ByteString) -> ByteString -> ByteString -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
forall s. FoldCase s => s -> s
foldCase (ByteString -> ByteString -> Bool)
-> ByteString -> ByteString -> Bool
forall a b. (a -> b) -> a -> b
$ ByteString
"text/html") Response ByteString
resp) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
          let htmlContent :: ByteString
htmlContent = ByteString -> ByteString
forall s. FoldCase s => s -> s
foldCase (ByteString -> ByteString)
-> (ByteString -> ByteString) -> ByteString -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int64 -> ByteString -> ByteString
LBS.take Int64
20 (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Response ByteString -> ByteString
forall body. Response body -> body
responseBody Response ByteString
resp
          Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (ByteString -> ByteString -> Bool
LBS.isPrefixOf (ByteString -> ByteString
forall s. FoldCase s => s -> s
foldCase ByteString
"<!doctype html>") ByteString
htmlContent) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
            PredicateFailure -> IO ()
forall a e. Exception e => e -> a
throw (PredicateFailure -> IO ()) -> PredicateFailure -> IO ()
forall a b. (a -> b) -> a -> b
$ Text -> Maybe Request -> Response ByteString -> PredicateFailure
PredicateFailure Text
"htmlIncludesDoctype" Maybe Request
forall a. Maybe a
Nothing Response ByteString
resp

-- * Predicate logic

-- The idea with all this footwork is to not waste any requests. Rather than
-- generating new requests and only applying one predicate to the response, we
-- apply as many predicates as possible.
--
-- Still, this is all kind of ugly.

-- | A predicate that depends only on the response.
--
-- /Since 0.0.0.0/
newtype ResponsePredicate = ResponsePredicate
  { ResponsePredicate -> Response ByteString -> IO ()
getResponsePredicate :: Response LBS.ByteString -> IO ()
  } deriving ((forall x. ResponsePredicate -> Rep ResponsePredicate x)
-> (forall x. Rep ResponsePredicate x -> ResponsePredicate)
-> Generic ResponsePredicate
forall x. Rep ResponsePredicate x -> ResponsePredicate
forall x. ResponsePredicate -> Rep ResponsePredicate x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. ResponsePredicate -> Rep ResponsePredicate x
from :: forall x. ResponsePredicate -> Rep ResponsePredicate x
$cto :: forall x. Rep ResponsePredicate x -> ResponsePredicate
to :: forall x. Rep ResponsePredicate x -> ResponsePredicate
Generic)

instance Semigroup ResponsePredicate where
  ResponsePredicate Response ByteString -> IO ()
a <> :: ResponsePredicate -> ResponsePredicate -> ResponsePredicate
<> ResponsePredicate Response ByteString -> IO ()
b = (Response ByteString -> IO ()) -> ResponsePredicate
ResponsePredicate ((Response ByteString -> IO ()) -> ResponsePredicate)
-> (Response ByteString -> IO ()) -> ResponsePredicate
forall a b. (a -> b) -> a -> b
$ \Response ByteString
x -> Response ByteString -> IO ()
a Response ByteString
x IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Response ByteString -> IO ()
b Response ByteString
x

instance Monoid ResponsePredicate where
  mempty :: ResponsePredicate
mempty = (Response ByteString -> IO ()) -> ResponsePredicate
ResponsePredicate ((Response ByteString -> IO ()) -> ResponsePredicate)
-> (Response ByteString -> IO ()) -> ResponsePredicate
forall a b. (a -> b) -> a -> b
$ IO () -> Response ByteString -> IO ()
forall a b. a -> b -> a
const (IO () -> Response ByteString -> IO ())
-> IO () -> Response ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$ () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  mappend :: ResponsePredicate -> ResponsePredicate -> ResponsePredicate
mappend = ResponsePredicate -> ResponsePredicate -> ResponsePredicate
forall a. Semigroup a => a -> a -> a
(<>)

-- | A predicate that depends on both the request and the response.
--
-- /Since 0.0.0.0/
newtype RequestPredicate = RequestPredicate
  { RequestPredicate -> Request -> Manager -> IO [Response ByteString]
getRequestPredicate :: Request -> Manager -> IO [Response LBS.ByteString]
  } deriving ((forall x. RequestPredicate -> Rep RequestPredicate x)
-> (forall x. Rep RequestPredicate x -> RequestPredicate)
-> Generic RequestPredicate
forall x. Rep RequestPredicate x -> RequestPredicate
forall x. RequestPredicate -> Rep RequestPredicate x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. RequestPredicate -> Rep RequestPredicate x
from :: forall x. RequestPredicate -> Rep RequestPredicate x
$cto :: forall x. Rep RequestPredicate x -> RequestPredicate
to :: forall x. Rep RequestPredicate x -> RequestPredicate
Generic)

-- TODO: This isn't actually a monoid
instance Monoid RequestPredicate where
  mempty :: RequestPredicate
mempty = (Request -> Manager -> IO [Response ByteString])
-> RequestPredicate
RequestPredicate (\Request
r Manager
m -> Request -> Manager -> IO (Response ByteString)
httpLbs Request
r Manager
m IO (Response ByteString)
-> (Response ByteString -> IO [Response ByteString])
-> IO [Response ByteString]
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Response ByteString
x -> [Response ByteString] -> IO [Response ByteString]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [Response ByteString
x])
  mappend :: RequestPredicate -> RequestPredicate -> RequestPredicate
mappend = RequestPredicate -> RequestPredicate -> RequestPredicate
forall a. Semigroup a => a -> a -> a
(<>)

-- TODO: This isn't actually a monoid
instance Semigroup RequestPredicate where
  RequestPredicate Request -> Manager -> IO [Response ByteString]
a <> :: RequestPredicate -> RequestPredicate -> RequestPredicate
<> RequestPredicate Request -> Manager -> IO [Response ByteString]
b = (Request -> Manager -> IO [Response ByteString])
-> RequestPredicate
RequestPredicate ((Request -> Manager -> IO [Response ByteString])
 -> RequestPredicate)
-> (Request -> Manager -> IO [Response ByteString])
-> RequestPredicate
forall a b. (a -> b) -> a -> b
$ \Request
r Manager
mgr ->
    ([Response ByteString]
 -> [Response ByteString] -> [Response ByteString])
-> IO [Response ByteString]
-> IO [Response ByteString]
-> IO [Response ByteString]
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 [Response ByteString]
-> [Response ByteString] -> [Response ByteString]
forall a. Semigroup a => a -> a -> a
(<>) (Request -> Manager -> IO [Response ByteString]
a Request
r Manager
mgr) (Request -> Manager -> IO [Response ByteString]
b Request
r Manager
mgr)

-- | A set of predicates. Construct one with 'mempty' and '<%>'.
data Predicates = Predicates
  { Predicates -> RequestPredicate
requestPredicates  :: RequestPredicate
  , Predicates -> ResponsePredicate
responsePredicates :: ResponsePredicate
  } deriving ((forall x. Predicates -> Rep Predicates x)
-> (forall x. Rep Predicates x -> Predicates) -> Generic Predicates
forall x. Rep Predicates x -> Predicates
forall x. Predicates -> Rep Predicates x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. Predicates -> Rep Predicates x
from :: forall x. Predicates -> Rep Predicates x
$cto :: forall x. Rep Predicates x -> Predicates
to :: forall x. Rep Predicates x -> Predicates
Generic)

instance Semigroup Predicates where
  Predicates
a <> :: Predicates -> Predicates -> Predicates
<> Predicates
b = RequestPredicate -> ResponsePredicate -> Predicates
Predicates (Predicates -> RequestPredicate
requestPredicates Predicates
a RequestPredicate -> RequestPredicate -> RequestPredicate
forall a. Semigroup a => a -> a -> a
<> Predicates -> RequestPredicate
requestPredicates Predicates
b)
                      (Predicates -> ResponsePredicate
responsePredicates Predicates
a ResponsePredicate -> ResponsePredicate -> ResponsePredicate
forall a. Semigroup a => a -> a -> a
<> Predicates -> ResponsePredicate
responsePredicates Predicates
b)

instance Monoid Predicates where
  mempty :: Predicates
mempty = RequestPredicate -> ResponsePredicate -> Predicates
Predicates RequestPredicate
forall a. Monoid a => a
mempty ResponsePredicate
forall a. Monoid a => a
mempty
  mappend :: Predicates -> Predicates -> Predicates
mappend = Predicates -> Predicates -> Predicates
forall a. Semigroup a => a -> a -> a
(<>)

class JoinPreds a where
  joinPreds :: a -> Predicates -> Predicates

instance JoinPreds RequestPredicate where
  joinPreds :: RequestPredicate -> Predicates -> Predicates
joinPreds RequestPredicate
p (Predicates RequestPredicate
x ResponsePredicate
y) = RequestPredicate -> ResponsePredicate -> Predicates
Predicates (RequestPredicate
p RequestPredicate -> RequestPredicate -> RequestPredicate
forall a. Semigroup a => a -> a -> a
<> RequestPredicate
x) ResponsePredicate
y

instance JoinPreds ResponsePredicate where
  joinPreds :: ResponsePredicate -> Predicates -> Predicates
joinPreds ResponsePredicate
p (Predicates RequestPredicate
x ResponsePredicate
y) = RequestPredicate -> ResponsePredicate -> Predicates
Predicates RequestPredicate
x (ResponsePredicate
p ResponsePredicate -> ResponsePredicate -> ResponsePredicate
forall a. Semigroup a => a -> a -> a
<> ResponsePredicate
y)

-- | Adds a new predicate (either `ResponsePredicate` or `RequestPredicate`) to
-- the existing predicates.
--
-- > not500 <%> onlyJsonObjects <%> empty
--
-- /Since 0.0.0.0/
(<%>) :: JoinPreds a => a -> Predicates -> Predicates
<%> :: forall a. JoinPreds a => a -> Predicates -> Predicates
(<%>) = a -> Predicates -> Predicates
forall a. JoinPreds a => a -> Predicates -> Predicates
joinPreds
infixr 6 <%>

finishPredicates :: Predicates -> Request -> Manager -> IO (Maybe PredicateFailure)
finishPredicates :: Predicates -> Request -> Manager -> IO (Maybe PredicateFailure)
finishPredicates Predicates
p Request
req Manager
mgr = IO (Maybe PredicateFailure)
go IO (Maybe PredicateFailure)
-> (PredicateFailure -> IO (Maybe PredicateFailure))
-> IO (Maybe PredicateFailure)
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` \(PredicateFailure
e :: PredicateFailure) -> Maybe PredicateFailure -> IO (Maybe PredicateFailure)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe PredicateFailure -> IO (Maybe PredicateFailure))
-> Maybe PredicateFailure -> IO (Maybe PredicateFailure)
forall a b. (a -> b) -> a -> b
$ PredicateFailure -> Maybe PredicateFailure
forall a. a -> Maybe a
Just PredicateFailure
e
  where
    go :: IO (Maybe PredicateFailure)
go = do
     [Response ByteString]
resps <- RequestPredicate -> Request -> Manager -> IO [Response ByteString]
getRequestPredicate (Predicates -> RequestPredicate
requestPredicates Predicates
p) Request
req Manager
mgr
     (Response ByteString -> IO ()) -> [Response ByteString] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_  (ResponsePredicate -> Response ByteString -> IO ()
getResponsePredicate (ResponsePredicate -> Response ByteString -> IO ())
-> ResponsePredicate -> Response ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$ Predicates -> ResponsePredicate
responsePredicates Predicates
p) [Response ByteString]
resps
     Maybe PredicateFailure -> IO (Maybe PredicateFailure)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe PredicateFailure
forall a. Maybe a
Nothing

-- * helpers

hasValidHeader :: SBS.ByteString -> (SBS.ByteString -> Bool) -> Response b -> Bool
hasValidHeader :: forall b. ByteString -> (ByteString -> Bool) -> Response b -> Bool
hasValidHeader ByteString
hdr ByteString -> Bool
p Response b
r = Bool -> (ByteString -> Bool) -> Maybe ByteString -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False ByteString -> Bool
p (HeaderName -> [(HeaderName, ByteString)] -> Maybe ByteString
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup (ByteString -> HeaderName
forall s. FoldCase s => s -> CI s
mk ByteString
hdr) (Response b -> [(HeaderName, ByteString)]
forall body. Response body -> [(HeaderName, ByteString)]
responseHeaders Response b
r))

isRFC822Date :: SBS.ByteString -> Bool
isRFC822Date :: ByteString -> Bool
isRFC822Date ByteString
s
  = case Bool -> TimeLocale -> String -> String -> Maybe UTCTime
forall (m :: * -> *) t.
(MonadFail m, ParseTime t) =>
Bool -> TimeLocale -> String -> String -> m t
parseTimeM Bool
True TimeLocale
defaultTimeLocale String
rfc822DateFormat (ByteString -> String
SBSC.unpack ByteString
s) of
    Maybe UTCTime
Nothing -> Bool
False
    Just (UTCTime
_ :: UTCTime) -> Bool
True

status2XX :: Monad m => Maybe Request -> Response LBS.ByteString -> T.Text -> m ()
status2XX :: forall (m :: * -> *).
Monad m =>
Maybe Request -> Response ByteString -> Text -> m ()
status2XX Maybe Request
mreq Response ByteString
resp Text
t
  | Status
status200 Status -> Status -> Bool
forall a. Ord a => a -> a -> Bool
<= Response ByteString -> Status
forall body. Response body -> Status
responseStatus Response ByteString
resp Bool -> Bool -> Bool
&& Response ByteString -> Status
forall body. Response body -> Status
responseStatus Response ByteString
resp Status -> Status -> Bool
forall a. Ord a => a -> a -> Bool
< Status
status300
  = () -> m ()
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  | Bool
otherwise = PredicateFailure -> m ()
forall a e. Exception e => e -> a
throw (PredicateFailure -> m ()) -> PredicateFailure -> m ()
forall a b. (a -> b) -> a -> b
$ Text -> Maybe Request -> Response ByteString -> PredicateFailure
PredicateFailure Text
t Maybe Request
mreq Response ByteString
resp