summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorAdrian Cochrane <adrian@openwork.nz>2020-12-20 19:44:19 +1300
committerAdrian Cochrane <adrian@openwork.nz>2020-12-20 19:44:19 +1300
commit9faa5334d97b51c95bc9c31c7523140ad1417443 (patch)
treed2784ae7d2b8b884e259ca6be3b89093e507bbbe
parent14a0ac0496d3d98982c45407948eba5bf915536f (diff)
downloadhurl-9faa5334d97b51c95bc9c31c7523140ad1417443.tar.gz
hurl-9faa5334d97b51c95bc9c31c7523140ad1417443.tar.bz2
hurl-9faa5334d97b51c95bc9c31c7523140ad1417443.zip
Utilize the cache HURL's been writing!
-rw-r--r--src/Network/URI/Cache.hs30
1 files changed, 21 insertions, 9 deletions
diff --git a/src/Network/URI/Cache.hs b/src/Network/URI/Cache.hs
index d8b9b50..5951ea8 100644
--- a/src/Network/URI/Cache.hs
+++ b/src/Network/URI/Cache.hs
@@ -1,5 +1,5 @@
{-# LANGUAGE OverloadedStrings #-}
-module Network.URI.Cache(shouldCacheHTTP) where -- , storeCacheHTTP, writeCacheHTTP)
+module Network.URI.Cache(shouldCacheHTTP, cacheHTTP, readCacheHTTP) where
import Network.HTTP.Client
import Network.HTTP.Types.Status
import Network.HTTP.Types.Header
@@ -16,7 +16,7 @@ import System.IO as IO
import System.FilePath
import System.Directory
-import Data.Maybe (mapMaybe, listToMaybe, isJust, isNothing, fromMaybe)
+import Data.Maybe
import Data.Char (isSpace)
import Data.List as L
import Control.Monad (forM)
@@ -59,27 +59,39 @@ computeExpires resp
cacheHTTP :: URI -> Response Lazy.ByteString -> IO ()
cacheHTTP uri resp | shouldCacheHTTP resp = do
expires <- computeExpires resp
- write (uriToString' uri) ([
+ writeKV (uriToString' uri) ([
("mime", C.unpack $ fromMaybe "application/octet-stream" $
lookup "content-type" $ responseHeaders resp),
("expires", show expires)
], responseBody resp)
cacheHTTP _ _ = return ()
+readCacheHTTP :: URI -> IO (Maybe (String, Lazy.ByteString))
+readCacheHTTP uri = do
+ (headers, body) <- readKV (uriToString' uri)
+ let mime = fromMaybe "application/octet-stream" $ lookup "mime" headers
+ case readMaybe =<< lookup "expires" headers of
+ Nothing -> return Nothing
+ Just expiry -> do
+ now <- getCurrentTime
+ if expiry <= now then return $ Just (mime, body)
+ else do
+ -- TODO validate via a HEAD request
+ return Nothing
------
--- Key-value storage
------
-read :: String -> IO ([(String, String)], Lazy.ByteString)
-write :: String -> ([(String, String)], Lazy.ByteString) -> IO ()
-openKey :: String -> IO.IOMode -> (Handle -> IO r) -> IO r
+readKV :: String -> IO ([(String, String)], Lazy.ByteString)
+writeKV :: String -> ([(String, String)], Lazy.ByteString) -> IO ()
+openKV :: String -> IO.IOMode -> (Handle -> IO r) -> IO r
-openKey key mode act = do
+openKV key mode act = do
dir <- getXdgDirectory XdgCache "nz.geek.adrian.hurl"
IO.withFile (dir </> "http" </> escapeURIString isUnescapedInURIComponent key) mode act
-read key = openKey key ReadMode parseHeaders
+readKV key = openKV key ReadMode parseHeaders
where
parseHeaders h = do
line <- IO.hGetLine h
@@ -92,7 +104,7 @@ read key = openKey key ReadMode parseHeaders
return ((key, strip' value):headers, body)
strip' = L.dropWhile isSpace . L.dropWhileEnd isSpace
-write key (headers, body) = openKey key WriteMode $ \h -> do
+writeKV key (headers, body) = openKV key WriteMode $ \h -> do
forM headers $ \(key, value) -> do
IO.hPutStrLn h (key++' ':value)
IO.hPutStrLn h ""