From 9faa5334d97b51c95bc9c31c7523140ad1417443 Mon Sep 17 00:00:00 2001
From: Adrian Cochrane <adrian@openwork.nz>
Date: Sun, 20 Dec 2020 19:44:19 +1300
Subject: [PATCH] Utilize the cache HURL's been writing!

---
 src/Network/URI/Cache.hs | 30 +++++++++++++++++++++---------
 1 file 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 ""
-- 
2.30.2