{-# LANGUAGE CPP, DeriveDataTypeable, DeriveFunctor, DeriveGeneric,
    FlexibleContexts, OverloadedStrings, RecordWildCards #-}

module Network.Wreq.Cache
    (
      shouldCache
    , validateEntry
    , cacheStore
    ) where

import Control.Applicative
import Control.Lens ((^?), (^.), (^..), folded, non, pre, to)
import Control.Monad (guard)
import Data.Attoparsec.ByteString.Char8 as A
import Data.CaseInsensitive (mk)
import Data.Foldable (forM_)
import Data.HashSet (HashSet)
import Data.Hashable (Hashable)
import Data.IntSet (IntSet)
import Data.IORef (newIORef)
import Data.List (sort)
import Data.Maybe (listToMaybe)
import Data.Monoid (First(..), mconcat)
import Data.Time.Clock (UTCTime, addUTCTime, getCurrentTime)
import Data.Time.Format (parseTimeM)
import Data.Time.Locale.Compat (defaultTimeLocale)
import Data.Typeable (Typeable)
import GHC.Generics (Generic)
import Network.HTTP.Types (HeaderName, Method)
import Network.Wreq.Internal.Lens
import Network.Wreq.Internal.Types
import Network.Wreq.Lens
import qualified Data.ByteString.Char8 as B
import qualified Data.HashSet as HashSet
import qualified Data.IntSet as IntSet
import qualified Network.Wreq.Cache.Store as Store

#if MIN_VERSION_base(4,6,0)
import Data.IORef (atomicModifyIORef')
#else
import Data.IORef (IORef, atomicModifyIORef)

atomicModifyIORef' :: IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' = atomicModifyIORef
#endif

cacheStore :: Int -> IO (Run body -> Run body)
cacheStore :: Int -> IO (Run body -> Run body)
cacheStore Int
capacity = do
  IORef (Store ByteString (CacheEntry body))
cache <- Store ByteString (CacheEntry body)
-> IO (IORef (Store ByteString (CacheEntry body)))
forall a. a -> IO (IORef a)
newIORef (Int -> Store ByteString (CacheEntry body)
forall k v. Ord k => Int -> Store k v
Store.empty Int
capacity)
  (Run body -> Run body) -> IO (Run body -> Run body)
forall (m :: * -> *) a. Monad m => a -> m a
return ((Run body -> Run body) -> IO (Run body -> Run body))
-> (Run body -> Run body) -> IO (Run body -> Run body)
forall a b. (a -> b) -> a -> b
$ \Run body
run Req
req -> do
    let url :: ByteString
url = Req -> ByteString
reqURL Req
req
    UTCTime
before <- IO UTCTime
getCurrentTime
    Maybe (Response body)
mresp <- IORef (Store ByteString (CacheEntry body))
-> (Store ByteString (CacheEntry body)
    -> (Store ByteString (CacheEntry body), Maybe (Response body)))
-> IO (Maybe (Response body))
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef (Store ByteString (CacheEntry body))
cache ((Store ByteString (CacheEntry body)
  -> (Store ByteString (CacheEntry body), Maybe (Response body)))
 -> IO (Maybe (Response body)))
-> (Store ByteString (CacheEntry body)
    -> (Store ByteString (CacheEntry body), Maybe (Response body)))
-> IO (Maybe (Response body))
forall a b. (a -> b) -> a -> b
$ \Store ByteString (CacheEntry body)
s ->
      case ByteString
-> Store ByteString (CacheEntry body)
-> Maybe (CacheEntry body, Store ByteString (CacheEntry body))
forall k v.
(Ord k, Hashable k) =>
k -> Store k v -> Maybe (v, Store k v)
Store.lookup ByteString
url Store ByteString (CacheEntry body)
s of
        Maybe (CacheEntry body, Store ByteString (CacheEntry body))
Nothing       -> (Store ByteString (CacheEntry body)
s, Maybe (Response body)
forall a. Maybe a
Nothing)
        Just (CacheEntry body
ce, Store ByteString (CacheEntry body)
s') ->
          case UTCTime -> CacheEntry body -> Maybe (Response body)
forall body. UTCTime -> CacheEntry body -> Maybe (Response body)
validateEntry UTCTime
before CacheEntry body
ce of
            n :: Maybe (Response body)
n@Maybe (Response body)
Nothing -> (ByteString
-> Store ByteString (CacheEntry body)
-> Store ByteString (CacheEntry body)
forall k v. (Ord k, Hashable k) => k -> Store k v -> Store k v
Store.delete ByteString
url Store ByteString (CacheEntry body)
s, Maybe (Response body)
n)
            Maybe (Response body)
resp      -> (Store ByteString (CacheEntry body)
s', Maybe (Response body)
resp)
    case Maybe (Response body)
mresp of
      Just Response body
resp -> Response body -> IO (Response body)
forall (m :: * -> *) a. Monad m => a -> m a
return Response body
resp
      Maybe (Response body)
Nothing -> do
        Response body
resp <- Run body
run Req
req
        UTCTime
after <- IO UTCTime
getCurrentTime
        Maybe (CacheEntry body) -> (CacheEntry body -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (UTCTime -> Req -> Response body -> Maybe (CacheEntry body)
forall body.
UTCTime -> Req -> Response body -> Maybe (CacheEntry body)
shouldCache UTCTime
after Req
req Response body
resp) ((CacheEntry body -> IO ()) -> IO ())
-> (CacheEntry body -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \CacheEntry body
ce ->
          IORef (Store ByteString (CacheEntry body))
-> (Store ByteString (CacheEntry body)
    -> (Store ByteString (CacheEntry body), ()))
-> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef (Store ByteString (CacheEntry body))
cache ((Store ByteString (CacheEntry body)
  -> (Store ByteString (CacheEntry body), ()))
 -> IO ())
-> (Store ByteString (CacheEntry body)
    -> (Store ByteString (CacheEntry body), ()))
-> IO ()
forall a b. (a -> b) -> a -> b
$ \Store ByteString (CacheEntry body)
s -> (ByteString
-> CacheEntry body
-> Store ByteString (CacheEntry body)
-> Store ByteString (CacheEntry body)
forall k v. (Ord k, Hashable k) => k -> v -> Store k v -> Store k v
Store.insert ByteString
url CacheEntry body
ce Store ByteString (CacheEntry body)
s, ())
        Response body -> IO (Response body)
forall (m :: * -> *) a. Monad m => a -> m a
return Response body
resp

cacheableStatuses :: IntSet
cacheableStatuses :: IntSet
cacheableStatuses = [Int] -> IntSet
IntSet.fromList [Int
200, Int
203, Int
300, Int
301, Int
410]

cacheableMethods :: HashSet Method
cacheableMethods :: HashSet ByteString
cacheableMethods = [ByteString] -> HashSet ByteString
forall a. (Eq a, Hashable a) => [a] -> HashSet a
HashSet.fromList [ByteString
"GET", ByteString
"HEAD", ByteString
"OPTIONS"]

possiblyCacheable :: Request -> Response body -> Bool
possiblyCacheable :: Request -> Response body -> Bool
possiblyCacheable Request
req Response body
resp =
    (Request
req Request -> Getting ByteString Request ByteString -> ByteString
forall s a. s -> Getting a s a -> a
^. Getting ByteString Request ByteString
Lens' Request ByteString
method) ByteString -> HashSet ByteString -> Bool
forall a. (Eq a, Hashable a) => a -> HashSet a -> Bool
`HashSet.member` HashSet ByteString
cacheableMethods Bool -> Bool -> Bool
&&
    (Response body
resp Response body -> Getting Int (Response body) Int -> Int
forall s a. s -> Getting a s a -> a
^. (Status -> Const Int Status)
-> Response body -> Const Int (Response body)
forall body. Lens' (Response body) Status
responseStatus ((Status -> Const Int Status)
 -> Response body -> Const Int (Response body))
-> ((Int -> Const Int Int) -> Status -> Const Int Status)
-> Getting Int (Response body) Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> Const Int Int) -> Status -> Const Int Status
Lens' Status Int
statusCode) Int -> IntSet -> Bool
`IntSet.member` IntSet
cacheableStatuses

computeExpiration :: UTCTime -> [CacheResponse Seconds] -> Maybe UTCTime
computeExpiration :: UTCTime -> [CacheResponse Int] -> Maybe UTCTime
computeExpiration UTCTime
now [CacheResponse Int]
crs = do
  Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> Bool -> Maybe ()
forall a b. (a -> b) -> a -> b
$ [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and [[HeaderName] -> CacheResponse Int
forall age. [HeaderName] -> CacheResponse age
NoCache [] CacheResponse Int -> [CacheResponse Int] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [CacheResponse Int]
crs, CacheResponse Int
forall age. CacheResponse age
NoStore CacheResponse Int -> [CacheResponse Int] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [CacheResponse Int]
crs]
  Int
age <- [Int] -> Maybe Int
forall a. [a] -> Maybe a
listToMaybe ([Int] -> Maybe Int) -> [Int] -> Maybe Int
forall a b. (a -> b) -> a -> b
$ [Int] -> [Int]
forall a. Ord a => [a] -> [a]
sort [Int
age | MaxAge Int
age <- [CacheResponse Int]
crs]
  UTCTime -> Maybe UTCTime
forall (m :: * -> *) a. Monad m => a -> m a
return (UTCTime -> Maybe UTCTime) -> UTCTime -> Maybe UTCTime
forall a b. (a -> b) -> a -> b
$! Int -> NominalDiffTime
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
age NominalDiffTime -> UTCTime -> UTCTime
`addUTCTime` UTCTime
now

validateEntry :: UTCTime -> CacheEntry body -> Maybe (Response body)
validateEntry :: UTCTime -> CacheEntry body -> Maybe (Response body)
validateEntry UTCTime
now CacheEntry{Maybe UTCTime
UTCTime
Response body
entryResponse :: forall body. CacheEntry body -> Response body
entryExpires :: forall body. CacheEntry body -> Maybe UTCTime
entryCreated :: forall body. CacheEntry body -> UTCTime
entryResponse :: Response body
entryExpires :: Maybe UTCTime
entryCreated :: UTCTime
..} =
  case Maybe UTCTime
entryExpires of
    Maybe UTCTime
Nothing          -> Response body -> Maybe (Response body)
forall a. a -> Maybe a
Just Response body
entryResponse
    Just UTCTime
e | UTCTime
e UTCTime -> UTCTime -> Bool
forall a. Ord a => a -> a -> Bool
> UTCTime
now -> Response body -> Maybe (Response body)
forall a. a -> Maybe a
Just Response body
entryResponse
    Maybe UTCTime
_                -> Maybe (Response body)
forall a. Maybe a
Nothing

shouldCache :: UTCTime -> Req -> Response body -> Maybe (CacheEntry body)
shouldCache :: UTCTime -> Req -> Response body -> Maybe (CacheEntry body)
shouldCache UTCTime
now (Req Mgr
_ Request
req) Response body
resp = do
  Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Request -> Response body -> Bool
forall body. Request -> Response body -> Bool
possiblyCacheable Request
req Response body
resp)
  let crs :: [CacheResponse Int]
crs = Response body
resp Response body
-> Getting
     (Endo [CacheResponse Int]) (Response body) (CacheResponse Int)
-> [CacheResponse Int]
forall s a. s -> Getting (Endo [a]) s a -> [a]
^.. HeaderName -> Traversal' (Response body) ByteString
forall body. HeaderName -> Traversal' (Response body) ByteString
responseHeader HeaderName
"Cache-Control" ((ByteString -> Const (Endo [CacheResponse Int]) ByteString)
 -> Response body
 -> Const (Endo [CacheResponse Int]) (Response body))
-> ((CacheResponse Int
     -> Const (Endo [CacheResponse Int]) (CacheResponse Int))
    -> ByteString -> Const (Endo [CacheResponse Int]) ByteString)
-> Getting
     (Endo [CacheResponse Int]) (Response body) (CacheResponse Int)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Parser [CacheResponse Int] -> Fold ByteString [CacheResponse Int]
forall a. Parser a -> Fold ByteString a
atto_ Parser [CacheResponse Int]
parseCacheResponse (([CacheResponse Int]
  -> Const (Endo [CacheResponse Int]) [CacheResponse Int])
 -> ByteString -> Const (Endo [CacheResponse Int]) ByteString)
-> ((CacheResponse Int
     -> Const (Endo [CacheResponse Int]) (CacheResponse Int))
    -> [CacheResponse Int]
    -> Const (Endo [CacheResponse Int]) [CacheResponse Int])
-> (CacheResponse Int
    -> Const (Endo [CacheResponse Int]) (CacheResponse Int))
-> ByteString
-> Const (Endo [CacheResponse Int]) ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
                     (CacheResponse Int
 -> Const (Endo [CacheResponse Int]) (CacheResponse Int))
-> [CacheResponse Int]
-> Const (Endo [CacheResponse Int]) [CacheResponse Int]
forall (f :: * -> *) a. Foldable f => IndexedFold Int (f a) a
folded ((CacheResponse Int
  -> Const (Endo [CacheResponse Int]) (CacheResponse Int))
 -> [CacheResponse Int]
 -> Const (Endo [CacheResponse Int]) [CacheResponse Int])
-> ((CacheResponse Int
     -> Const (Endo [CacheResponse Int]) (CacheResponse Int))
    -> CacheResponse Int
    -> Const (Endo [CacheResponse Int]) (CacheResponse Int))
-> (CacheResponse Int
    -> Const (Endo [CacheResponse Int]) (CacheResponse Int))
-> [CacheResponse Int]
-> Const (Endo [CacheResponse Int]) [CacheResponse Int]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (CacheResponse Int -> CacheResponse Int)
-> (CacheResponse Int
    -> Const (Endo [CacheResponse Int]) (CacheResponse Int))
-> CacheResponse Int
-> Const (Endo [CacheResponse Int]) (CacheResponse Int)
forall (p :: * -> * -> *) (f :: * -> *) s a.
(Profunctor p, Contravariant f) =>
(s -> a) -> Optic' p f s a
to CacheResponse Int -> CacheResponse Int
forall age. CacheResponse age -> CacheResponse age
simplifyCacheResponse
      dateHeader :: HeaderName
-> p UTCTime (f UTCTime) -> Response body -> f (Response body)
dateHeader HeaderName
name = HeaderName -> Traversal' (Response body) ByteString
forall body. HeaderName -> Traversal' (Response body) ByteString
responseHeader HeaderName
name ((ByteString -> f ByteString)
 -> Response body -> f (Response body))
-> (p UTCTime (f UTCTime) -> ByteString -> f ByteString)
-> p UTCTime (f UTCTime)
-> Response body
-> f (Response body)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ByteString -> Maybe UTCTime)
-> Optic' (->) f ByteString (Maybe UTCTime)
forall (p :: * -> * -> *) (f :: * -> *) s a.
(Profunctor p, Contravariant f) =>
(s -> a) -> Optic' p f s a
to ByteString -> Maybe UTCTime
parseDate Optic' (->) f ByteString (Maybe UTCTime)
-> (p UTCTime (f UTCTime) -> Maybe UTCTime -> f (Maybe UTCTime))
-> p UTCTime (f UTCTime)
-> ByteString
-> f ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. p UTCTime (f UTCTime) -> Maybe UTCTime -> f (Maybe UTCTime)
forall (f :: * -> *) a. Foldable f => IndexedFold Int (f a) a
folded
      mexpires :: Maybe UTCTime
mexpires = case [CacheResponse Int]
crs of
                   [] -> Response body
resp Response body
-> Getting (First UTCTime) (Response body) UTCTime -> Maybe UTCTime
forall s a. s -> Getting (First a) s a -> Maybe a
^? HeaderName -> Getting (First UTCTime) (Response body) UTCTime
forall (f :: * -> *) (p :: * -> * -> *) body.
(Contravariant f, Indexable Int p, Applicative f) =>
HeaderName
-> p UTCTime (f UTCTime) -> Response body -> f (Response body)
dateHeader HeaderName
"Expires"
                   [CacheResponse Int]
_  -> UTCTime -> [CacheResponse Int] -> Maybe UTCTime
computeExpiration UTCTime
now [CacheResponse Int]
crs
      created :: UTCTime
created = Response body
resp Response body -> Getting UTCTime (Response body) UTCTime -> UTCTime
forall s a. s -> Getting a s a -> a
^. Getting (First UTCTime) (Response body) UTCTime
-> IndexPreservingGetter (Response body) (Maybe UTCTime)
forall a s.
Getting (First a) s a -> IndexPreservingGetter s (Maybe a)
pre (HeaderName -> Getting (First UTCTime) (Response body) UTCTime
forall (f :: * -> *) (p :: * -> * -> *) body.
(Contravariant f, Indexable Int p, Applicative f) =>
HeaderName
-> p UTCTime (f UTCTime) -> Response body -> f (Response body)
dateHeader HeaderName
"Date") ((Maybe UTCTime -> Const UTCTime (Maybe UTCTime))
 -> Response body -> Const UTCTime (Response body))
-> ((UTCTime -> Const UTCTime UTCTime)
    -> Maybe UTCTime -> Const UTCTime (Maybe UTCTime))
-> Getting UTCTime (Response body) UTCTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UTCTime -> Iso' (Maybe UTCTime) UTCTime
forall a. Eq a => a -> Iso' (Maybe a) a
non UTCTime
now
  case Maybe UTCTime
mexpires of
    Just UTCTime
expires | UTCTime
expires UTCTime -> UTCTime -> Bool
forall a. Ord a => a -> a -> Bool
<= UTCTime
created                -> Maybe (CacheEntry body)
forall (f :: * -> *) a. Alternative f => f a
empty
    Maybe UTCTime
Nothing      | Request
req Request -> Getting ByteString Request ByteString -> ByteString
forall s a. s -> Getting a s a -> a
^. Getting ByteString Request ByteString
Lens' Request ByteString
method ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
"GET" Bool -> Bool -> Bool
&&
                   Bool -> Bool
not (ByteString -> Bool
B.null (Request
req Request -> Getting ByteString Request ByteString -> ByteString
forall s a. s -> Getting a s a -> a
^. Getting ByteString Request ByteString
Lens' Request ByteString
queryString)) -> Maybe (CacheEntry body)
forall (f :: * -> *) a. Alternative f => f a
empty
    Maybe UTCTime
_ -> CacheEntry body -> Maybe (CacheEntry body)
forall (m :: * -> *) a. Monad m => a -> m a
return (CacheEntry body -> Maybe (CacheEntry body))
-> CacheEntry body -> Maybe (CacheEntry body)
forall a b. (a -> b) -> a -> b
$ UTCTime -> Maybe UTCTime -> Response body -> CacheEntry body
forall body.
UTCTime -> Maybe UTCTime -> Response body -> CacheEntry body
CacheEntry UTCTime
created Maybe UTCTime
mexpires Response body
resp

type Seconds = Int

data CacheResponse age = Public
                       | Private [HeaderName]
                       | NoCache [HeaderName]
                       | NoStore
                       | NoTransform
                       | MustRevalidate
                       | ProxyRevalidate
                       | MaxAge age
                       | SMaxAge age
                       | Extension
                       deriving (CacheResponse age -> CacheResponse age -> Bool
(CacheResponse age -> CacheResponse age -> Bool)
-> (CacheResponse age -> CacheResponse age -> Bool)
-> Eq (CacheResponse age)
forall age.
Eq age =>
CacheResponse age -> CacheResponse age -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: CacheResponse age -> CacheResponse age -> Bool
$c/= :: forall age.
Eq age =>
CacheResponse age -> CacheResponse age -> Bool
== :: CacheResponse age -> CacheResponse age -> Bool
$c== :: forall age.
Eq age =>
CacheResponse age -> CacheResponse age -> Bool
Eq, Int -> CacheResponse age -> ShowS
[CacheResponse age] -> ShowS
CacheResponse age -> String
(Int -> CacheResponse age -> ShowS)
-> (CacheResponse age -> String)
-> ([CacheResponse age] -> ShowS)
-> Show (CacheResponse age)
forall age. Show age => Int -> CacheResponse age -> ShowS
forall age. Show age => [CacheResponse age] -> ShowS
forall age. Show age => CacheResponse age -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [CacheResponse age] -> ShowS
$cshowList :: forall age. Show age => [CacheResponse age] -> ShowS
show :: CacheResponse age -> String
$cshow :: forall age. Show age => CacheResponse age -> String
showsPrec :: Int -> CacheResponse age -> ShowS
$cshowsPrec :: forall age. Show age => Int -> CacheResponse age -> ShowS
Show, a -> CacheResponse b -> CacheResponse a
(a -> b) -> CacheResponse a -> CacheResponse b
(forall a b. (a -> b) -> CacheResponse a -> CacheResponse b)
-> (forall a b. a -> CacheResponse b -> CacheResponse a)
-> Functor CacheResponse
forall a b. a -> CacheResponse b -> CacheResponse a
forall a b. (a -> b) -> CacheResponse a -> CacheResponse b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> CacheResponse b -> CacheResponse a
$c<$ :: forall a b. a -> CacheResponse b -> CacheResponse a
fmap :: (a -> b) -> CacheResponse a -> CacheResponse b
$cfmap :: forall a b. (a -> b) -> CacheResponse a -> CacheResponse b
Functor, Typeable, (forall x. CacheResponse age -> Rep (CacheResponse age) x)
-> (forall x. Rep (CacheResponse age) x -> CacheResponse age)
-> Generic (CacheResponse age)
forall x. Rep (CacheResponse age) x -> CacheResponse age
forall x. CacheResponse age -> Rep (CacheResponse age) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall age x. Rep (CacheResponse age) x -> CacheResponse age
forall age x. CacheResponse age -> Rep (CacheResponse age) x
$cto :: forall age x. Rep (CacheResponse age) x -> CacheResponse age
$cfrom :: forall age x. CacheResponse age -> Rep (CacheResponse age) x
Generic)

instance Hashable age => Hashable (CacheResponse age)

simplifyCacheResponse :: CacheResponse age -> CacheResponse age
simplifyCacheResponse :: CacheResponse age -> CacheResponse age
simplifyCacheResponse (Private [HeaderName]
_) = [HeaderName] -> CacheResponse age
forall age. [HeaderName] -> CacheResponse age
Private []
simplifyCacheResponse (NoCache [HeaderName]
_) = [HeaderName] -> CacheResponse age
forall age. [HeaderName] -> CacheResponse age
NoCache []
simplifyCacheResponse CacheResponse age
cr          = CacheResponse age
cr

parseCacheResponse :: A.Parser [CacheResponse Seconds]
parseCacheResponse :: Parser [CacheResponse Int]
parseCacheResponse = Parser ByteString (CacheResponse Int) -> Parser [CacheResponse Int]
forall a. Parser ByteString a -> Parser ByteString [a]
commaSep1 Parser ByteString (CacheResponse Int)
body
  where
    body :: Parser ByteString (CacheResponse Int)
body = Parser ByteString ByteString
"public" Parser ByteString ByteString
-> Parser ByteString (CacheResponse Int)
-> Parser ByteString (CacheResponse Int)
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> CacheResponse Int -> Parser ByteString (CacheResponse Int)
forall (f :: * -> *) a. Applicative f => a -> f a
pure CacheResponse Int
forall age. CacheResponse age
Public
       Parser ByteString (CacheResponse Int)
-> Parser ByteString (CacheResponse Int)
-> Parser ByteString (CacheResponse Int)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser ByteString ByteString
"private" Parser ByteString ByteString
-> Parser ByteString (CacheResponse Int)
-> Parser ByteString (CacheResponse Int)
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ([HeaderName] -> CacheResponse Int
forall age. [HeaderName] -> CacheResponse age
Private ([HeaderName] -> CacheResponse Int)
-> Parser ByteString [HeaderName]
-> Parser ByteString (CacheResponse Int)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Parser ByteString [HeaderName] -> Parser ByteString [HeaderName]
forall b. Parser ByteString b -> Parser ByteString b
eq Parser ByteString [HeaderName]
headerNames Parser ByteString [HeaderName]
-> Parser ByteString [HeaderName] -> Parser ByteString [HeaderName]
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> [HeaderName] -> Parser ByteString [HeaderName]
forall (f :: * -> *) a. Applicative f => a -> f a
pure []))
       Parser ByteString (CacheResponse Int)
-> Parser ByteString (CacheResponse Int)
-> Parser ByteString (CacheResponse Int)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser ByteString ByteString
"no-cache" Parser ByteString ByteString
-> Parser ByteString (CacheResponse Int)
-> Parser ByteString (CacheResponse Int)
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ([HeaderName] -> CacheResponse Int
forall age. [HeaderName] -> CacheResponse age
NoCache ([HeaderName] -> CacheResponse Int)
-> Parser ByteString [HeaderName]
-> Parser ByteString (CacheResponse Int)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Parser ByteString [HeaderName] -> Parser ByteString [HeaderName]
forall b. Parser ByteString b -> Parser ByteString b
eq Parser ByteString [HeaderName]
headerNames Parser ByteString [HeaderName]
-> Parser ByteString [HeaderName] -> Parser ByteString [HeaderName]
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> [HeaderName] -> Parser ByteString [HeaderName]
forall (f :: * -> *) a. Applicative f => a -> f a
pure []))
       Parser ByteString (CacheResponse Int)
-> Parser ByteString (CacheResponse Int)
-> Parser ByteString (CacheResponse Int)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser ByteString ByteString
"no-store" Parser ByteString ByteString
-> Parser ByteString (CacheResponse Int)
-> Parser ByteString (CacheResponse Int)
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> CacheResponse Int -> Parser ByteString (CacheResponse Int)
forall (f :: * -> *) a. Applicative f => a -> f a
pure CacheResponse Int
forall age. CacheResponse age
NoStore
       Parser ByteString (CacheResponse Int)
-> Parser ByteString (CacheResponse Int)
-> Parser ByteString (CacheResponse Int)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser ByteString ByteString
"no-transform" Parser ByteString ByteString
-> Parser ByteString (CacheResponse Int)
-> Parser ByteString (CacheResponse Int)
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> CacheResponse Int -> Parser ByteString (CacheResponse Int)
forall (f :: * -> *) a. Applicative f => a -> f a
pure CacheResponse Int
forall age. CacheResponse age
NoTransform
       Parser ByteString (CacheResponse Int)
-> Parser ByteString (CacheResponse Int)
-> Parser ByteString (CacheResponse Int)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser ByteString ByteString
"must-revalidate" Parser ByteString ByteString
-> Parser ByteString (CacheResponse Int)
-> Parser ByteString (CacheResponse Int)
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> CacheResponse Int -> Parser ByteString (CacheResponse Int)
forall (f :: * -> *) a. Applicative f => a -> f a
pure CacheResponse Int
forall age. CacheResponse age
MustRevalidate
       Parser ByteString (CacheResponse Int)
-> Parser ByteString (CacheResponse Int)
-> Parser ByteString (CacheResponse Int)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser ByteString ByteString
"proxy-revalidate" Parser ByteString ByteString
-> Parser ByteString (CacheResponse Int)
-> Parser ByteString (CacheResponse Int)
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> CacheResponse Int -> Parser ByteString (CacheResponse Int)
forall (f :: * -> *) a. Applicative f => a -> f a
pure CacheResponse Int
forall age. CacheResponse age
ProxyRevalidate
       Parser ByteString (CacheResponse Int)
-> Parser ByteString (CacheResponse Int)
-> Parser ByteString (CacheResponse Int)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser ByteString ByteString
"max-age" Parser ByteString ByteString
-> Parser ByteString (CacheResponse Int)
-> Parser ByteString (CacheResponse Int)
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser ByteString (CacheResponse Int)
-> Parser ByteString (CacheResponse Int)
forall b. Parser ByteString b -> Parser ByteString b
eq (Int -> CacheResponse Int
forall age. age -> CacheResponse age
MaxAge (Int -> CacheResponse Int)
-> Parser ByteString Int -> Parser ByteString (CacheResponse Int)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser ByteString Int
forall a. Integral a => Parser a
decimal)
       Parser ByteString (CacheResponse Int)
-> Parser ByteString (CacheResponse Int)
-> Parser ByteString (CacheResponse Int)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser ByteString ByteString
"s-maxage" Parser ByteString ByteString
-> Parser ByteString (CacheResponse Int)
-> Parser ByteString (CacheResponse Int)
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser ByteString (CacheResponse Int)
-> Parser ByteString (CacheResponse Int)
forall b. Parser ByteString b -> Parser ByteString b
eq (Int -> CacheResponse Int
forall age. age -> CacheResponse age
SMaxAge (Int -> CacheResponse Int)
-> Parser ByteString Int -> Parser ByteString (CacheResponse Int)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser ByteString Int
forall a. Integral a => Parser a
decimal)
    headerNames :: Parser ByteString [HeaderName]
headerNames = Char -> Parser Char
A.char Char
'"' Parser Char
-> Parser ByteString [HeaderName] -> Parser ByteString [HeaderName]
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser ByteString HeaderName -> Parser ByteString [HeaderName]
forall a. Parser ByteString a -> Parser ByteString [a]
commaSep1 Parser ByteString HeaderName
hdr Parser ByteString [HeaderName]
-> Parser Char -> Parser ByteString [HeaderName]
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Char -> Parser Char
A.char Char
'"'
    hdr :: Parser ByteString HeaderName
hdr = ByteString -> HeaderName
forall s. FoldCase s => s -> CI s
mk (ByteString -> HeaderName)
-> Parser ByteString ByteString -> Parser ByteString HeaderName
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Char -> Bool) -> Parser ByteString ByteString
A.takeWhile1 (String -> Char -> Bool
inClass String
"a-zA-Z0-9_-")
    commaSep1 :: Parser ByteString a -> Parser ByteString [a]
commaSep1 Parser ByteString a
p = (Parser ByteString a
p Parser ByteString a -> Parser ByteString () -> Parser ByteString a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ByteString ()
skipSpace) Parser ByteString a
-> Parser ByteString () -> Parser ByteString [a]
forall (f :: * -> *) a s. Alternative f => f a -> f s -> f [a]
`sepBy1` (Char -> Parser Char
A.char Char
',' Parser Char -> Parser ByteString () -> Parser ByteString ()
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser ByteString ()
skipSpace)
    eq :: Parser ByteString b -> Parser ByteString b
eq Parser ByteString b
p = Parser ByteString ()
skipSpace Parser ByteString () -> Parser Char -> Parser Char
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Char -> Parser Char
A.char Char
'=' Parser Char -> Parser ByteString () -> Parser ByteString ()
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser ByteString ()
skipSpace Parser ByteString () -> Parser ByteString b -> Parser ByteString b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser ByteString b
p

parseDate :: B.ByteString -> Maybe UTCTime
parseDate :: ByteString -> Maybe UTCTime
parseDate ByteString
s = First UTCTime -> Maybe UTCTime
forall a. First a -> Maybe a
getFirst (First UTCTime -> Maybe UTCTime)
-> ([String] -> First UTCTime) -> [String] -> Maybe UTCTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [First UTCTime] -> First UTCTime
forall a. Monoid a => [a] -> a
mconcat ([First UTCTime] -> First UTCTime)
-> ([String] -> [First UTCTime]) -> [String] -> First UTCTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> First UTCTime) -> [String] -> [First UTCTime]
forall a b. (a -> b) -> [a] -> [b]
map String -> First UTCTime
forall a. ParseTime a => String -> First a
tryout ([String] -> Maybe UTCTime) -> [String] -> Maybe UTCTime
forall a b. (a -> b) -> a -> b
$ [
    String
"%a, %d %b %Y %H:%M:%S %Z"
  , String
"%A, %d-%b-%y %H:%M:%S %Z"
  , String
"%a %b %e %H:%M:%S %Y"
  ]
  where tryout :: String -> First a
tryout String
fmt = Maybe a -> First a
forall a. Maybe a -> First a
First (Maybe a -> First a) -> Maybe a -> First a
forall a b. (a -> b) -> a -> b
$ Bool -> TimeLocale -> String -> String -> Maybe a
forall (m :: * -> *) t.
(MonadFail m, ParseTime t) =>
Bool -> TimeLocale -> String -> String -> m t
parseTimeM Bool
True TimeLocale
defaultTimeLocale String
fmt (ByteString -> String
B.unpack ByteString
s)