Write appropriate HTTP responses to the cache!

1 files changed, 40 insertions, 9 deletions

diff --git a/src/Network/URI/Cache.hs b/src/Network/URI/Cache.hs
index 5adba85..c84e11a 100644
--- a/src/Network/URI/Cache.hs
+++ b/src/Network/URI/Cache.hs
@@ -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 ""