~alcinnz/hurl

ff57d15db3fdae1a9d473e18347d32a624a68cd1 — Adrian Cochrane 4 years ago 53ee542
Write appropriate HTTP responses to the cache!
1 files changed, 40 insertions(+), 9 deletions(-)

M src/Network/URI/Cache.hs
M src/Network/URI/Cache.hs => src/Network/URI/Cache.hs +40 -9
@@ 5,18 5,22 @@ import Network.HTTP.Types.Status
import Network.HTTP.Types.Header

-- For escaping filepaths, since I already have this dependency
import Network.URI (escapeURIString, isUnescapedInURIComponent)
import Network.URI (escapeURIString, isUnescapedInURIComponent, URI, uriToString)
import Data.Time.Clock
import Data.Time.Format

import Data.ByteString as Strict
import Data.ByteString.Char8 as C
import Data.ByteString.Lazy as Lazy
import System.IO as IO
import System.FilePath
import System.Directory

import Data.Maybe (mapMaybe, listToMaybe, isJust, isNothing)
import Data.Maybe (mapMaybe, listToMaybe, isJust, isNothing, fromMaybe)
import Data.Char (isSpace)
import Data.List as L
import Control.Monad (forM)
import Text.Read (readMaybe)

strip = C.dropWhile isSpace -- FIXME Upgrade bytestring dependency for a real strip function.



@@ 38,19 42,46 @@ shouldCacheHTTP response = -- Assume GET
        isJust (httpCacheDirective response "max-age") ||
        isJust (httpCacheDirective response "public")) -- Override directive

uriToString' uri = uriToString id uri ""
parseHTTPTime str | ',' `L.elem` str = parseTimeM True defaultTimeLocale rfc822DateFormat str
parseHTTPTime str = parseTimeM True defaultTimeLocale "%_d %b %Y %H:%M:%S %Z" str
secondsFromNow i = do
    now <- getCurrentTime
    -- This ugliness required because regex depends on outdated version of time.
    return $ addUTCTime (fromRational $ toRational $ secondsToDiffTime i) now

computeExpires :: Response a -> IO UTCTime
computeExpires resp
  | Just header <- lookup hExpires $ responseHeaders resp,
        Just time <- parseHTTPTime $ C.unpack header = return time
  | Just pragma <- httpCacheDirective resp "max-age",
        Just seconds <- readMaybe $ C.unpack pragma = secondsFromNow seconds
  | otherwise = secondsFromNow (60*60*24) -- One day

cacheHTTP :: URI -> Response Lazy.ByteString -> IO ()
cacheHTTP uri resp | shouldCacheHTTP resp = do
    expires <- computeExpires resp
    write (uriToString' uri) ([
            ("mime", C.unpack $ fromMaybe "application/octet-stream" $ 
                    lookup "content-type" $ responseHeaders resp),
            ("expires", show expires)
        ], responseBody resp)
cacheHTTP _ _ = return ()


------
--- Key-value storage
------

read :: FilePath -> String -> IO ([(String, String)], Lazy.ByteString)
write :: FilePath -> String -> ([(String, String)], Lazy.ByteString) -> IO ()
openKey :: FilePath -> String -> (Handle -> IO r) -> IO r
read :: String -> IO ([(String, String)], Lazy.ByteString)
write :: String -> ([(String, String)], Lazy.ByteString) -> IO ()
openKey :: String -> IO.IOMode -> (Handle -> IO r) -> IO r

openKey dir key =
    IO.withFile (dir </> escapeURIString isUnescapedInURIComponent key) ReadMode
openKey key mode act = do
    dir <- getXdgDirectory XdgCache "nz.geek.adrian.hurl"
    IO.withFile (dir </> "http" </> escapeURIString isUnescapedInURIComponent key) mode act

read dir key = openKey dir key parseHeaders
read key = openKey key ReadMode parseHeaders
  where
    parseHeaders h = do
        line <- IO.hGetLine h


@@ 63,7 94,7 @@ read dir key = openKey dir key parseHeaders
                return ((key, strip' value):headers, body)
    strip' = L.dropWhile isSpace . L.dropWhileEnd isSpace

write dir key (headers, body) = openKey dir key $ \h -> do
write key (headers, body) = openKey key WriteMode $ \h -> do
    forM headers $ \(key, value) -> do
        IO.hPutStrLn h (key++' ':value)
    IO.hPutStrLn h ""