{-# 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 :: forall body. Seconds -> IO (Run body -> Run body)
cacheStore Seconds
capacity = do
  IORef (Store Method (CacheEntry body))
cache <- Store Method (CacheEntry body)
-> IO (IORef (Store Method (CacheEntry body)))
forall a. a -> IO (IORef a)
newIORef (Seconds -> Store Method (CacheEntry body)
forall k v. Ord k => Seconds -> Store k v
Store.empty Seconds
capacity)
  (Run body -> Run body) -> IO (Run body -> Run body)
forall a. a -> IO a
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 :: Method
url = Req -> Method
reqURL Req
req
    UTCTime
before <- IO UTCTime
getCurrentTime
    Maybe (Response body)
mresp <- IORef (Store Method (CacheEntry body))
-> (Store Method (CacheEntry body)
    -> (Store Method (CacheEntry body), Maybe (Response body)))
-> IO (Maybe (Response body))
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef (Store Method (CacheEntry body))
cache ((Store Method (CacheEntry body)
  -> (Store Method (CacheEntry body), Maybe (Response body)))
 -> IO (Maybe (Response body)))
-> (Store Method (CacheEntry body)
    -> (Store Method (CacheEntry body), Maybe (Response body)))
-> IO (Maybe (Response body))
forall a b. (a -> b) -> a -> b
$ \Store Method (CacheEntry body)
s ->
      case Method
-> Store Method (CacheEntry body)
-> Maybe (CacheEntry body, Store Method (CacheEntry body))
forall k v.
(Ord k, Hashable k) =>
k -> Store k v -> Maybe (v, Store k v)
Store.lookup Method
url Store Method (CacheEntry body)
s of
        Maybe (CacheEntry body, Store Method (CacheEntry body))
Nothing       -> (Store Method (CacheEntry body)
s, Maybe (Response body)
forall a. Maybe a
Nothing)
        Just (CacheEntry body
ce, Store Method (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 -> (Method
-> Store Method (CacheEntry body) -> Store Method (CacheEntry body)
forall k v. (Ord k, Hashable k) => k -> Store k v -> Store k v
Store.delete Method
url Store Method (CacheEntry body)
s, Maybe (Response body)
n)
            Maybe (Response body)
resp      -> (Store Method (CacheEntry body)
s', Maybe (Response body)
resp)
    case Maybe (Response body)
mresp of
      Just Response body
resp -> Response body -> IO (Response body)
forall a. a -> IO a
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 Method (CacheEntry body))
-> (Store Method (CacheEntry body)
    -> (Store Method (CacheEntry body), ()))
-> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef (Store Method (CacheEntry body))
cache ((Store Method (CacheEntry body)
  -> (Store Method (CacheEntry body), ()))
 -> IO ())
-> (Store Method (CacheEntry body)
    -> (Store Method (CacheEntry body), ()))
-> IO ()
forall a b. (a -> b) -> a -> b
$ \Store Method (CacheEntry body)
s -> (Method
-> CacheEntry body
-> Store Method (CacheEntry body)
-> Store Method (CacheEntry body)
forall k v. (Ord k, Hashable k) => k -> v -> Store k v -> Store k v
Store.insert Method
url CacheEntry body
ce Store Method (CacheEntry body)
s, ())
        Response body -> IO (Response body)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Response body
resp

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

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

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

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

validateEntry :: UTCTime -> CacheEntry body -> Maybe (Response body)
validateEntry :: forall body. UTCTime -> CacheEntry body -> Maybe (Response body)
validateEntry UTCTime
now CacheEntry{Maybe UTCTime
UTCTime
Response body
entryCreated :: UTCTime
entryExpires :: Maybe UTCTime
entryResponse :: Response body
entryCreated :: forall body. CacheEntry body -> UTCTime
entryExpires :: forall body. CacheEntry body -> Maybe UTCTime
entryResponse :: forall body. CacheEntry body -> Response body
..} =
  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 :: forall body.
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 Seconds]
crs = Response body
resp Response body
-> Getting
     (Endo [CacheResponse Seconds])
     (Response body)
     (CacheResponse Seconds)
-> [CacheResponse Seconds]
forall s a. s -> Getting (Endo [a]) s a -> [a]
^.. HeaderName -> Traversal' (Response body) Method
forall body. HeaderName -> Traversal' (Response body) Method
responseHeader HeaderName
"Cache-Control" ((Method -> Const (Endo [CacheResponse Seconds]) Method)
 -> Response body
 -> Const (Endo [CacheResponse Seconds]) (Response body))
-> ((CacheResponse Seconds
     -> Const (Endo [CacheResponse Seconds]) (CacheResponse Seconds))
    -> Method -> Const (Endo [CacheResponse Seconds]) Method)
-> Getting
     (Endo [CacheResponse Seconds])
     (Response body)
     (CacheResponse Seconds)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Parser [CacheResponse Seconds]
-> Fold Method [CacheResponse Seconds]
forall a. Parser a -> Fold Method a
atto_ Parser [CacheResponse Seconds]
parseCacheResponse (([CacheResponse Seconds]
  -> Const (Endo [CacheResponse Seconds]) [CacheResponse Seconds])
 -> Method -> Const (Endo [CacheResponse Seconds]) Method)
-> ((CacheResponse Seconds
     -> Const (Endo [CacheResponse Seconds]) (CacheResponse Seconds))
    -> [CacheResponse Seconds]
    -> Const (Endo [CacheResponse Seconds]) [CacheResponse Seconds])
-> (CacheResponse Seconds
    -> Const (Endo [CacheResponse Seconds]) (CacheResponse Seconds))
-> Method
-> Const (Endo [CacheResponse Seconds]) Method
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
                     (CacheResponse Seconds
 -> Const (Endo [CacheResponse Seconds]) (CacheResponse Seconds))
-> [CacheResponse Seconds]
-> Const (Endo [CacheResponse Seconds]) [CacheResponse Seconds]
forall (f :: * -> *) a. Foldable f => IndexedFold Seconds (f a) a
IndexedFold Seconds [CacheResponse Seconds] (CacheResponse Seconds)
folded ((CacheResponse Seconds
  -> Const (Endo [CacheResponse Seconds]) (CacheResponse Seconds))
 -> [CacheResponse Seconds]
 -> Const (Endo [CacheResponse Seconds]) [CacheResponse Seconds])
-> ((CacheResponse Seconds
     -> Const (Endo [CacheResponse Seconds]) (CacheResponse Seconds))
    -> CacheResponse Seconds
    -> Const (Endo [CacheResponse Seconds]) (CacheResponse Seconds))
-> (CacheResponse Seconds
    -> Const (Endo [CacheResponse Seconds]) (CacheResponse Seconds))
-> [CacheResponse Seconds]
-> Const (Endo [CacheResponse Seconds]) [CacheResponse Seconds]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (CacheResponse Seconds -> CacheResponse Seconds)
-> (CacheResponse Seconds
    -> Const (Endo [CacheResponse Seconds]) (CacheResponse Seconds))
-> CacheResponse Seconds
-> Const (Endo [CacheResponse Seconds]) (CacheResponse Seconds)
forall (p :: * -> * -> *) (f :: * -> *) s a.
(Profunctor p, Contravariant f) =>
(s -> a) -> Optic' p f s a
to CacheResponse Seconds -> CacheResponse Seconds
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) Method
forall body. HeaderName -> Traversal' (Response body) Method
responseHeader HeaderName
name ((Method -> f Method) -> Response body -> f (Response body))
-> (p UTCTime (f UTCTime) -> Method -> f Method)
-> p UTCTime (f UTCTime)
-> Response body
-> f (Response body)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Method -> Maybe UTCTime)
-> (Maybe UTCTime -> f (Maybe UTCTime)) -> Method -> f Method
forall (p :: * -> * -> *) (f :: * -> *) s a.
(Profunctor p, Contravariant f) =>
(s -> a) -> Optic' p f s a
to Method -> Maybe UTCTime
parseDate ((Maybe UTCTime -> f (Maybe UTCTime)) -> Method -> f Method)
-> (p UTCTime (f UTCTime) -> Maybe UTCTime -> f (Maybe UTCTime))
-> p UTCTime (f UTCTime)
-> Method
-> f Method
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 Seconds (f a) a
IndexedFold Seconds (Maybe UTCTime) UTCTime
folded
      mexpires :: Maybe UTCTime
mexpires = case [CacheResponse Seconds]
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 Seconds p, Applicative f) =>
HeaderName
-> p UTCTime (f UTCTime) -> Response body -> f (Response body)
dateHeader HeaderName
"Expires"
                   [CacheResponse Seconds]
_  -> UTCTime -> [CacheResponse Seconds] -> Maybe UTCTime
computeExpiration UTCTime
now [CacheResponse Seconds]
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 Seconds 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 a. Maybe a
forall (f :: * -> *) a. Alternative f => f a
empty
    Maybe UTCTime
Nothing      | Request
req Request -> Getting Method Request Method -> Method
forall s a. s -> Getting a s a -> a
^. Getting Method Request Method
Lens' Request Method
method Method -> Method -> Bool
forall a. Eq a => a -> a -> Bool
== Method
"GET" Bool -> Bool -> Bool
&&
                   Bool -> Bool
not (Method -> Bool
B.null (Request
req Request -> Getting Method Request Method -> Method
forall s a. s -> Getting a s a -> a
^. Getting Method Request Method
Lens' Request Method
queryString)) -> Maybe (CacheEntry body)
forall a. Maybe a
forall (f :: * -> *) a. Alternative f => f a
empty
    Maybe UTCTime
_ -> CacheEntry body -> Maybe (CacheEntry body)
forall a. a -> Maybe a
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
$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
/= :: CacheResponse age -> CacheResponse age -> Bool
Eq, Seconds -> CacheResponse age -> ShowS
[CacheResponse age] -> ShowS
CacheResponse age -> String
(Seconds -> CacheResponse age -> ShowS)
-> (CacheResponse age -> String)
-> ([CacheResponse age] -> ShowS)
-> Show (CacheResponse age)
forall age. Show age => Seconds -> CacheResponse age -> ShowS
forall age. Show age => [CacheResponse age] -> ShowS
forall age. Show age => CacheResponse age -> String
forall a.
(Seconds -> a -> ShowS)
-> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall age. Show age => Seconds -> CacheResponse age -> ShowS
showsPrec :: Seconds -> CacheResponse age -> ShowS
$cshow :: forall age. Show age => CacheResponse age -> String
show :: CacheResponse age -> String
$cshowList :: forall age. Show age => [CacheResponse age] -> ShowS
showList :: [CacheResponse age] -> ShowS
Show, (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
$cfmap :: forall a b. (a -> b) -> CacheResponse a -> CacheResponse b
fmap :: forall a b. (a -> b) -> CacheResponse a -> CacheResponse b
$c<$ :: forall a b. a -> CacheResponse b -> CacheResponse a
<$ :: forall a b. a -> CacheResponse b -> CacheResponse a
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
$cfrom :: forall age x. CacheResponse age -> Rep (CacheResponse age) x
from :: forall x. CacheResponse age -> Rep (CacheResponse age) x
$cto :: forall age x. Rep (CacheResponse age) x -> CacheResponse age
to :: forall x. Rep (CacheResponse age) x -> CacheResponse age
Generic)

instance Hashable age => Hashable (CacheResponse age)

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

parseDate :: B.ByteString -> Maybe UTCTime
parseDate :: Method -> Maybe UTCTime
parseDate Method
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 (Method -> String
B.unpack Method
s)