From 663fb7aad3813458f3b80bebaff79ba79ddf5db5 Mon Sep 17 00:00:00 2001
From: Adrian Cochrane <adrian@openwork.nz>
Date: Sun, 20 Dec 2020 21:30:31 +1300
Subject: [PATCH] Add support for cache validation.

This required redesigning the internal APIs & refactoring the code to read better.
---
 src/Network/URI/Cache.hs | 65 +++++++++++++++++++++++++++-------------
 1 file changed, 44 insertions(+), 21 deletions(-)

diff --git a/src/Network/URI/Cache.hs b/src/Network/URI/Cache.hs
index 5951ea8..01b47b1 100644
--- a/src/Network/URI/Cache.hs
+++ b/src/Network/URI/Cache.hs
@@ -19,7 +19,7 @@ import System.Directory
 import Data.Maybe
 import Data.Char (isSpace)
 import Data.List as L
-import Control.Monad (forM)
+import Control.Monad (forM, void, when)
 import Text.Read (readMaybe)
 
 strip = C.dropWhile isSpace -- FIXME Upgrade bytestring dependency for a real strip function.
@@ -41,6 +41,7 @@ shouldCacheHTTP response = -- Assume GET
         -- Also, I'll cache anything for supported response codes, regardless of explicit expiry times.
 
 uriToString' uri = uriToString id uri ""
+parseHTTPTime :: String -> Maybe UTCTime
 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
@@ -59,37 +60,57 @@ computeExpires resp
 cacheHTTP :: URI -> Response Lazy.ByteString -> IO ()
 cacheHTTP uri resp | shouldCacheHTTP resp = do
     expires <- computeExpires resp
-    writeKV (uriToString' uri) ([
-            ("mime", C.unpack $ fromMaybe "application/octet-stream" $ 
-                    lookup "content-type" $ responseHeaders resp),
-            ("expires", show expires)
-        ], responseBody resp)
+    let headers = responseHeaders resp
+    writeKV (uriToString' uri) (
+        [("expires", show expires)] ++ getHeader "content-type" "mime" ++
+            getHeader "ETag" "etag" ++ getHeader "Last-Modified" "modified",
+        responseBody resp)
+  where
+    getHeader header key | Just value <- lookup header $ responseHeaders resp = [(key, C.unpack value)]
+        | otherwise = []
 cacheHTTP _ _ = return ()
 
-readCacheHTTP :: URI -> IO (Maybe (String, Lazy.ByteString))
+readCacheHTTP :: URI -> IO (Maybe (String, Lazy.ByteString), Maybe ResponseHeaders)
 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
+    cached <- readKV $ uriToString' uri
+    case cached of
+        Just (headers, body) | Just expiry <- readMaybe =<< lookup "expires" headers -> do
+            let mime = fromMaybe "application/octet-stream" $ lookup "mime" headers
             now <- getCurrentTime
-            if expiry <= now then return $ Just (mime, body)
-            else do
-                -- TODO validate via a HEAD request
-                return Nothing
+
+            -- Headers for a validation request & whether should be sent.
+            let headers' = if expiry <= now then Nothing else Just (
+                    [("If-Modified-Since", C.pack val) | ("modified", val) <- headers,
+                        isJust $ parseHTTPTime val] ++
+                    [("If-None-Match", C.pack val) | ("etag", val) <- headers])
+            -- Cache entry has expired, delete.
+            when (isJust headers') $ deleteKV $ uriToString' uri
+
+            return (Just (mime, body), headers')
+
+        _ -> return (Nothing, Just [])
+
+
 
 ------
 --- Key-value storage
 ------
 
-readKV :: String -> IO ([(String, String)], Lazy.ByteString)
+readKV :: String -> IO (Maybe ([(String, String)], Lazy.ByteString))
 writeKV :: String -> ([(String, String)], Lazy.ByteString) -> IO ()
-openKV :: String -> IO.IOMode -> (Handle -> IO r) -> IO r
+deleteKV :: String -> IO ()
+openKV :: String -> IO.IOMode -> (Handle -> IO r) -> IO (Maybe r)
+pathKV :: String -> IO FilePath
 
-openKV key mode act = do
+pathKV key = do
     dir <- getXdgDirectory XdgCache "nz.geek.adrian.hurl"
-    IO.withFile (dir </> "http" </> escapeURIString isUnescapedInURIComponent key) mode act
+    createDirectoryIfMissing True (dir </> "http")
+    return (dir </> "http" </> escapeURIString isUnescapedInURIComponent key)
+
+openKV key mode act = do
+    path <- pathKV key
+    exists <- doesFileExist path
+    if exists then Just <$> IO.withFile path mode act else return Nothing
 
 readKV key = openKV key ReadMode parseHeaders
   where
@@ -104,8 +125,10 @@ readKV key = openKV key ReadMode parseHeaders
                 return ((key, strip' value):headers, body)
     strip' = L.dropWhile isSpace . L.dropWhileEnd isSpace
 
-writeKV key (headers, body) = openKV key WriteMode $ \h -> do
+writeKV key (headers, body) = void $ openKV key WriteMode $ \h -> do
     forM headers $ \(key, value) -> do
         IO.hPutStrLn h (key++' ':value)
     IO.hPutStrLn h ""
     Lazy.hPut h body
+
+deleteKV key = pathKV key >>= removeFile
-- 
2.30.2