1 files changed, 41 insertions(+), 2 deletions(-)

M 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