summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorAdrian Cochrane <adrian@openwork.nz>2020-12-14 20:47:28 +1300
committerAdrian Cochrane <adrian@openwork.nz>2020-12-14 20:47:28 +1300
commit53ee542a2785d96abf627d34d5462c639a5948b9 (patch)
treebef5e7ec292f1d67f3efe9c22c356a3600c8f5da
parenta4ffbfc2089a8704a5bb76b4aeded612697c20f2 (diff)
downloadhurl-53ee542a2785d96abf627d34d5462c639a5948b9.tar.gz
hurl-53ee542a2785d96abf627d34d5462c639a5948b9.tar.bz2
hurl-53ee542a2785d96abf627d34d5462c639a5948b9.zip
Implement key-value storage for caching (TODO limit disk usage)
-rw-r--r--src/Network/URI/Cache.hs43
1 files changed, 41 insertions, 2 deletions
diff --git a/src/Network/URI/Cache.hs b/src/Network/URI/Cache.hs
index 635826b..5adba85 100644
--- a/src/Network/URI/Cache.hs
+++ b/src/Network/URI/Cache.hs
@@ -4,15 +4,23 @@ import Network.HTTP.Client
import Network.HTTP.Types.Status
import Network.HTTP.Types.Header
-import Data.ByteString (ByteString)
+-- For escaping filepaths, since I already have this dependency
+import Network.URI (escapeURIString, isUnescapedInURIComponent)
+
+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 Data.Maybe (mapMaybe, listToMaybe, isJust, isNothing)
import Data.Char (isSpace)
+import Data.List as L
+import Control.Monad (forM)
strip = C.dropWhile isSpace -- FIXME Upgrade bytestring dependency for a real strip function.
-httpCacheDirective :: Response b -> ByteString -> Maybe ByteString
+httpCacheDirective :: Response b -> Strict.ByteString -> Maybe Strict.ByteString
httpCacheDirective response key | Just header <- lookup hCacheControl $ responseHeaders response =
let directives = Prelude.map strip $ C.split ',' header
in if key `Prelude.elem` directives
@@ -29,3 +37,34 @@ shouldCacheHTTP response = -- Assume GET
(isJust (lookup hExpires $ responseHeaders response) || -- Support Expires: header
isJust (httpCacheDirective response "max-age") ||
isJust (httpCacheDirective response "public")) -- Override directive
+
+
+------
+--- 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
+
+openKey dir key =
+ IO.withFile (dir </> escapeURIString isUnescapedInURIComponent key) ReadMode
+
+read dir key = openKey dir key parseHeaders
+ where
+ parseHeaders h = do
+ line <- IO.hGetLine h
+ case L.break isSpace $ strip' line of
+ ("", "") -> do
+ body <- Lazy.hGetContents h
+ return ([], body)
+ (key, value) -> do
+ (headers, body) <- parseHeaders h
+ return ((key, strip' value):headers, body)
+ strip' = L.dropWhile isSpace . L.dropWhileEnd isSpace
+
+write dir key (headers, body) = openKey dir key $ \h -> do
+ forM headers $ \(key, value) -> do
+ IO.hPutStrLn h (key++' ':value)
+ IO.hPutStrLn h ""
+ Lazy.hPut h body