{-# LANGUAGE OverloadedStrings #-}
module Network.URI.Cache(shouldCacheHTTP) where -- , storeCacheHTTP, writeCacheHTTP)
import Network.HTTP.Client
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 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 -> 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
            then Just ""
            else listToMaybe $ mapMaybe (C.stripPrefix $ C.snoc key '=') directives
    | otherwise = Nothing

shouldCacheHTTP :: Response b -> Bool
-- IETF RFC7234 Section 3
shouldCacheHTTP response = -- Assume GET
    statusCode (responseStatus response) `Prelude.elem` [200, 201, 404] && -- Supported response code
        isNothing (httpCacheDirective response "no-store") && -- Honor no-store
        True && -- This is a private cache, don't check for Cache-Control: private
        (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