Download resource with HTTP caching

Question

To validate jwt tokens at server I'm using jwk (Google) certs (changing frequently) and, even exist many libraries to download that (HTTP, curl, http-conduit, ...), I can't found the way to set some local/global/memory/per-thread/... HTTP cache.

My current ugly but feasible alternatives are:

1. read Cache-Control and/or Expires headers and perform my own ugly HTTP caching.
2. configure one (out of the box server) proxy.

How do you deal with HTTP caching at server?

Thank you!

Answer 1

Option 1 here

httpManager   <- newManager someManagerSettings
mySimpleCache <- makeSimpleHttpCache httpManager responseToMyCachedData
....
a <- mySimpleCache urlA
....

e.g. caching response body length

> c <- makeSimpleHttpCache m (\r -> putStrLn "Downloaded!" >> return $ C8.length $ responseBody r)
> c "https://some-url-with-small-cache-control"
Downloaded!
Right 21108
> c "https://some-url-with-small-cache-control"
Right 21108
> c "https://some-url-with-small-cache-control"
Right 21108
> c "https://some-url-with-small-cache-control"
Downloaded!
Right 21108
> c "https://some-url-with-small-cache-control"
Right 21108
>

code

{-# LANGUAGE OverloadedStrings #-}
module Network.HTTP.Client.Cached where

import Control.Monad.IO.Class
import Network.Connection
import Network.HTTP.Types
import Network.HTTP.Conduit
import Control.Concurrent.MVar
import qualified Data.ByteString.Char8 as C8
import qualified Data.ByteString.Lazy as L
import qualified Data.Map as M
import Data.Time.Format
import Data.Time.Calendar
import Data.Time.Clock
import Data.Time.Clock.POSIX
import Control.Arrow hiding ((+++))
import Control.Applicative
import Control.Monad.Catch
import Data.Maybe
import Text.ParserCombinators.ReadP
import Data.Char

type Res = Response L.ByteString

makeSimpleHttpCache :: (MonadCatch m, MonadIO m) => Manager -> (Res -> m a) -> m (String -> m (Either String a))
makeSimpleHttpCache manager onLoad = do
    cacheRef <- liftIO $ newMVar M.empty
    return $ \url -> do
        cache <- liftIO $ takeMVar cacheRef
        (cache', a) <- flip catchAll (\e -> return (cache, Left $ show e)) $ do
                            t <- liftIO getPOSIXTime
                            case (second (>t) <$> M.lookup url cache) of
                                Just (y, True) -> return (cache, Right y)
                                _ -> do
                                       u <- liftIO $ parseUrlThrow url
                                       r <- liftIO (httpLbs u manager)
                                       a <- onLoad r
                                       case computeExpireTime t r of
                                           Just t' -> return (M.insertWith const url (a, t') cache, Right a)
                                           _       -> return (cache, Right a)
        liftIO $ putMVar cacheRef cache'
        return a

computeExpireTime :: POSIXTime -> Res -> Maybe POSIXTime
computeExpireTime now rs =
    let hs              = responseHeaders rs
        expires         = do    e <- lookupHeader hExpires hs
                                t <- parseTimeM True defaultTimeLocale "%a, %e %b %Y %T %Z" (C8.unpack e)
                                return $ utcTimeToPOSIXSeconds t
        cachecontrol    = do    c <- lookupHeader hCacheControl hs
                                d <- readMaxAge $ C8.unpack c
                                return $ now + fromIntegral d
    in  cachecontrol <|> expires

readMaxAge :: String -> Maybe Int
readMaxAge = fmap fst . listToMaybe . readP_to_S p
    where p = (string "max-age=" >> read <$> munch isDigit) +++ (get >>= const p)

lookupHeader :: HeaderName -> [Header] -> Maybe C8.ByteString
lookupHeader h = listToMaybe . map snd . filter ((h==) . fst)

hExpires :: HeaderName
hExpires = "Expires"