使用 HTTP 缓存下载资源答案

【问题标题】：Download resource with HTTP caching使用 HTTP 缓存下载资源
【发布时间】：2015-09-17 08:22:44
【问题描述】：

为了验证服务器上的jwt 令牌，我使用jwk (Google) 证书（经常更改），甚至存在许多库可以下载它（HTTP、curl、http-conduit、 ...)，我找不到设置一些本地/全局/内存/每个线程/... HTTP 缓存的方法。

我目前丑陋但可行的替代方案是：

读取Cache-Control 和/或Expires 标头并执行我自己的丑陋HTTP 缓存。
配置一个（开箱即用的服务器）代理。

你如何处理服务器上的 HTTP 缓存？

谢谢！

【问题讨论】：

标签： http haskell caching server

【解决方案1】：

此处为选项 1

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

例如缓存响应体长度

> 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
>

代码

{-# 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"

【讨论】：

生产使用警告：此实现不处理失败的 URL。