{-# LANGUAGE OverloadedStrings #-}
module Network.URI.Cache(shouldCacheHTTP, cacheHTTP, readCacheHTTP, cleanCacheHTTP) where
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, 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 qualified Data.Text as Txt

import Data.Maybe
import Data.Char (isSpace)
import Data.List as L
import Control.Monad (forM, void, when)
import Text.Read (readMaybe)

strip :: ByteString -> ByteString
strip = (Char -> Bool) -> ByteString -> ByteString
C.dropWhile Char -> Bool
isSpace -- FIXME Upgrade bytestring dependency for a real strip function.

httpCacheDirective :: Response b -> Strict.ByteString -> Maybe Strict.ByteString
httpCacheDirective :: Response b -> ByteString -> Maybe ByteString
httpCacheDirective Response b
response ByteString
key | Just ByteString
header <- HeaderName -> [(HeaderName, ByteString)] -> Maybe ByteString
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup HeaderName
hCacheControl ([(HeaderName, ByteString)] -> Maybe ByteString)
-> [(HeaderName, ByteString)] -> Maybe ByteString
forall a b. (a -> b) -> a -> b
$ Response b -> [(HeaderName, ByteString)]
forall body. Response body -> [(HeaderName, ByteString)]
responseHeaders Response b
response =
        let directives :: [ByteString]
directives = (ByteString -> ByteString) -> [ByteString] -> [ByteString]
forall a b. (a -> b) -> [a] -> [b]
Prelude.map ByteString -> ByteString
strip ([ByteString] -> [ByteString]) -> [ByteString] -> [ByteString]
forall a b. (a -> b) -> a -> b
$ Char -> ByteString -> [ByteString]
C.split Char
',' ByteString
header
        in if ByteString
key ByteString -> [ByteString] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`Prelude.elem` [ByteString]
directives
            then ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ByteString
""
            else [ByteString] -> Maybe ByteString
forall a. [a] -> Maybe a
listToMaybe ([ByteString] -> Maybe ByteString)
-> [ByteString] -> Maybe ByteString
forall a b. (a -> b) -> a -> b
$ (ByteString -> Maybe ByteString) -> [ByteString] -> [ByteString]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (ByteString -> ByteString -> Maybe ByteString
C.stripPrefix (ByteString -> ByteString -> Maybe ByteString)
-> ByteString -> ByteString -> Maybe ByteString
forall a b. (a -> b) -> a -> b
$ ByteString -> Char -> ByteString
C.snoc ByteString
key Char
'=') [ByteString]
directives
    | Bool
otherwise = Maybe ByteString
forall a. Maybe a
Nothing

shouldCacheHTTP :: Response b -> Bool
-- IETF RFC7234 Section 3
shouldCacheHTTP :: Response b -> Bool
shouldCacheHTTP Response b
response = -- Assume GET
    Status -> Int
statusCode (Response b -> Status
forall body. Response body -> Status
responseStatus Response b
response) Int -> [Int] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`Prelude.elem` [Int
200, Int
201, Int
404] Bool -> Bool -> Bool
&& -- Supported response code
        Maybe ByteString -> Bool
forall a. Maybe a -> Bool
isNothing (Response b -> ByteString -> Maybe ByteString
forall b. Response b -> ByteString -> Maybe ByteString
httpCacheDirective Response b
response ByteString
"no-store") -- Honor no-store
        -- This is a private cache, don't check for Cache-Control: private
        -- Also, I'll cache anything for supported response codes, regardless of explicit expiry times.

uriToString' :: URI -> String
uriToString' URI
uri = (String -> String) -> URI -> String -> String
uriToString String -> String
forall a. a -> a
id URI
uri String
""
parseHTTPTime :: String -> Maybe UTCTime
parseHTTPTime :: String -> Maybe UTCTime
parseHTTPTime String
str | Char
',' Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`L.elem` String
str = Bool -> TimeLocale -> String -> String -> Maybe UTCTime
forall (m :: * -> *) t.
(MonadFail m, ParseTime t) =>
Bool -> TimeLocale -> String -> String -> m t
parseTimeM Bool
True TimeLocale
defaultTimeLocale String
rfc822DateFormat String
str
parseHTTPTime String
str = Bool -> TimeLocale -> String -> String -> Maybe UTCTime
forall (m :: * -> *) t.
(MonadFail m, ParseTime t) =>
Bool -> TimeLocale -> String -> String -> m t
parseTimeM Bool
True TimeLocale
defaultTimeLocale String
"%_d %b %Y %H:%M:%S %Z" String
str
secondsFromNow :: Integer -> IO UTCTime
secondsFromNow Integer
i = do
    UTCTime
now <- IO UTCTime
getCurrentTime
    -- This ugliness required because regex depends on outdated version of time.
    UTCTime -> IO UTCTime
forall (m :: * -> *) a. Monad m => a -> m a
return (UTCTime -> IO UTCTime) -> UTCTime -> IO UTCTime
forall a b. (a -> b) -> a -> b
$ NominalDiffTime -> UTCTime -> UTCTime
addUTCTime (Rational -> NominalDiffTime
forall a. Fractional a => Rational -> a
fromRational (Rational -> NominalDiffTime) -> Rational -> NominalDiffTime
forall a b. (a -> b) -> a -> b
$ DiffTime -> Rational
forall a. Real a => a -> Rational
toRational (DiffTime -> Rational) -> DiffTime -> Rational
forall a b. (a -> b) -> a -> b
$ Integer -> DiffTime
secondsToDiffTime Integer
i) UTCTime
now

computeExpires :: Response a -> IO UTCTime
computeExpires :: Response a -> IO UTCTime
computeExpires Response a
resp
  | Just ByteString
header <- HeaderName -> [(HeaderName, ByteString)] -> Maybe ByteString
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup HeaderName
hExpires ([(HeaderName, ByteString)] -> Maybe ByteString)
-> [(HeaderName, ByteString)] -> Maybe ByteString
forall a b. (a -> b) -> a -> b
$ Response a -> [(HeaderName, ByteString)]
forall body. Response body -> [(HeaderName, ByteString)]
responseHeaders Response a
resp,
        Just UTCTime
time <- String -> Maybe UTCTime
parseHTTPTime (String -> Maybe UTCTime) -> String -> Maybe UTCTime
forall a b. (a -> b) -> a -> b
$ ByteString -> String
C.unpack ByteString
header = UTCTime -> IO UTCTime
forall (m :: * -> *) a. Monad m => a -> m a
return UTCTime
time
  | Just ByteString
pragma <- Response a -> ByteString -> Maybe ByteString
forall b. Response b -> ByteString -> Maybe ByteString
httpCacheDirective Response a
resp ByteString
"max-age",
        Just Integer
seconds <- String -> Maybe Integer
forall a. Read a => String -> Maybe a
readMaybe (String -> Maybe Integer) -> String -> Maybe Integer
forall a b. (a -> b) -> a -> b
$ ByteString -> String
C.unpack ByteString
pragma = Integer -> IO UTCTime
secondsFromNow Integer
seconds
  | Bool
otherwise = Integer -> IO UTCTime
secondsFromNow (Integer
60Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
*Integer
60Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
*Integer
24) -- One day

cacheHTTP :: URI -> Response Lazy.ByteString -> IO ()
cacheHTTP :: URI -> Response ByteString -> IO ()
cacheHTTP URI
uri Response ByteString
resp | Response ByteString -> Bool
forall b. Response b -> Bool
shouldCacheHTTP Response ByteString
resp = do
    UTCTime
expires <- Response ByteString -> IO UTCTime
forall a. Response a -> IO UTCTime
computeExpires Response ByteString
resp
    let headers :: [(HeaderName, ByteString)]
headers = Response ByteString -> [(HeaderName, ByteString)]
forall body. Response body -> [(HeaderName, ByteString)]
responseHeaders Response ByteString
resp
    String -> ([(String, String)], ByteString) -> IO ()
writeKV (URI -> String
uriToString' URI
uri) (
        [(String
"expires", UTCTime -> String
forall a. Show a => a -> String
show UTCTime
expires)] [(String, String)] -> [(String, String)] -> [(String, String)]
forall a. [a] -> [a] -> [a]
++ HeaderName -> String -> [(String, String)]
forall a. HeaderName -> a -> [(a, String)]
getHeader HeaderName
"content-type" String
"mime" [(String, String)] -> [(String, String)] -> [(String, String)]
forall a. [a] -> [a] -> [a]
++
            HeaderName -> String -> [(String, String)]
forall a. HeaderName -> a -> [(a, String)]
getHeader HeaderName
"ETag" String
"etag" [(String, String)] -> [(String, String)] -> [(String, String)]
forall a. [a] -> [a] -> [a]
++ HeaderName -> String -> [(String, String)]
forall a. HeaderName -> a -> [(a, String)]
getHeader HeaderName
"Last-Modified" String
"modified",
        Response ByteString -> ByteString
forall body. Response body -> body
responseBody Response ByteString
resp)
  where
    getHeader :: HeaderName -> a -> [(a, String)]
getHeader HeaderName
header a
key | Just ByteString
value <- HeaderName -> [(HeaderName, ByteString)] -> Maybe ByteString
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup HeaderName
header ([(HeaderName, ByteString)] -> Maybe ByteString)
-> [(HeaderName, ByteString)] -> Maybe ByteString
forall a b. (a -> b) -> a -> b
$ Response ByteString -> [(HeaderName, ByteString)]
forall body. Response body -> [(HeaderName, ByteString)]
responseHeaders Response ByteString
resp = [(a
key, ByteString -> String
C.unpack ByteString
value)]
        | Bool
otherwise = []
cacheHTTP URI
_ Response ByteString
_ = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

readCacheHTTP :: URI -> IO (Maybe (Txt.Text, Lazy.ByteString), Maybe ResponseHeaders)
readCacheHTTP :: URI
-> IO (Maybe (Text, ByteString), Maybe [(HeaderName, ByteString)])
readCacheHTTP URI
uri = do
    Maybe ([(String, String)], ByteString)
cached <- String -> IO (Maybe ([(String, String)], ByteString))
readKV (String -> IO (Maybe ([(String, String)], ByteString)))
-> String -> IO (Maybe ([(String, String)], ByteString))
forall a b. (a -> b) -> a -> b
$ URI -> String
uriToString' URI
uri
    case Maybe ([(String, String)], ByteString)
cached of
        Just ([(String, String)]
headers, ByteString
body) | Just UTCTime
expiry <- String -> Maybe UTCTime
forall a. Read a => String -> Maybe a
readMaybe (String -> Maybe UTCTime) -> Maybe String -> Maybe UTCTime
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< String -> [(String, String)] -> Maybe String
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
"expires" [(String, String)]
headers -> do
            let mime :: String
mime = String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
"application/octet-stream" (Maybe String -> String) -> Maybe String -> String
forall a b. (a -> b) -> a -> b
$ String -> [(String, String)] -> Maybe String
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
"mime" [(String, String)]
headers
            UTCTime
now <- IO UTCTime
getCurrentTime

            -- Headers for a validation request & whether should be sent.
            let headers' :: Maybe [(HeaderName, ByteString)]
headers' = if UTCTime
expiry UTCTime -> UTCTime -> Bool
forall a. Ord a => a -> a -> Bool
<= UTCTime
now then Maybe [(HeaderName, ByteString)]
forall a. Maybe a
Nothing else [(HeaderName, ByteString)] -> Maybe [(HeaderName, ByteString)]
forall a. a -> Maybe a
Just (
                    [(HeaderName
"If-Modified-Since", String -> ByteString
C.pack String
val) | (String
"modified", String
val) <- [(String, String)]
headers,
                        Maybe UTCTime -> Bool
forall a. Maybe a -> Bool
isJust (Maybe UTCTime -> Bool) -> Maybe UTCTime -> Bool
forall a b. (a -> b) -> a -> b
$ String -> Maybe UTCTime
parseHTTPTime String
val] [(HeaderName, ByteString)]
-> [(HeaderName, ByteString)] -> [(HeaderName, ByteString)]
forall a. [a] -> [a] -> [a]
++
                    [(HeaderName
"If-None-Match", String -> ByteString
C.pack String
val) | (String
"etag", String
val) <- [(String, String)]
headers])
            -- Cache entry has expired, delete.
            Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Maybe [(HeaderName, ByteString)] -> Bool
forall a. Maybe a -> Bool
isJust Maybe [(HeaderName, ByteString)]
headers') (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
deleteKV (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ URI -> String
uriToString' URI
uri

            (Maybe (Text, ByteString), Maybe [(HeaderName, ByteString)])
-> IO (Maybe (Text, ByteString), Maybe [(HeaderName, ByteString)])
forall (m :: * -> *) a. Monad m => a -> m a
return ((Text, ByteString) -> Maybe (Text, ByteString)
forall a. a -> Maybe a
Just (String -> Text
Txt.pack String
mime, ByteString
body), Maybe [(HeaderName, ByteString)]
headers')

        Maybe ([(String, String)], ByteString)
_ -> (Maybe (Text, ByteString), Maybe [(HeaderName, ByteString)])
-> IO (Maybe (Text, ByteString), Maybe [(HeaderName, ByteString)])
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (Text, ByteString)
forall a. Maybe a
Nothing, [(HeaderName, ByteString)] -> Maybe [(HeaderName, ByteString)]
forall a. a -> Maybe a
Just [])

cleanCacheHTTP :: IO ()
cleanCacheHTTP = IO [()] -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO [()] -> IO ()) -> IO [()] -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    UTCTime
now <- IO UTCTime
getCurrentTime
    let tombstone :: UTCTime
tombstone = UTCTime
now

    String
dir <- XdgDirectory -> String -> IO String
getXdgDirectory XdgDirectory
XdgCache String
"nz.geek.adrian.hurl"
    Bool
dirExists <- String -> IO Bool
doesDirectoryExist (String
dir String -> String -> String
</> String
"http")
    [String]
files <- if Bool
dirExists then String -> IO [String]
listDirectory (String
dir String -> String -> String
</> String
"http") else [String] -> IO [String]
forall (m :: * -> *) a. Monad m => a -> m a
return []
    [String] -> (String -> IO ()) -> IO [()]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [String]
files ((String -> IO ()) -> IO [()]) -> (String -> IO ()) -> IO [()]
forall a b. (a -> b) -> a -> b
$ \String
file -> do
        Bool
exists <- String -> IO Bool
doesFileExist String
file
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
exists (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> IOMode -> (Handle -> IO ()) -> IO ()
forall r. String -> IOMode -> (Handle -> IO r) -> IO r
IO.withFile String
file IOMode
ReadMode ((Handle -> IO ()) -> IO ()) -> (Handle -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Handle
h -> do
            ([(String, String)]
headers, ByteString
_) <- Handle -> IO ([(String, String)], ByteString)
parseHeaders Handle
h
            let hasHeader :: String -> Bool
hasHeader String
h = Maybe String -> Bool
forall a. Maybe a -> Bool
isJust (Maybe String -> Bool) -> Maybe String -> Bool
forall a b. (a -> b) -> a -> b
$ String -> [(String, String)] -> Maybe String
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
h [(String, String)]
headers
                validatable :: Bool
validatable = String -> Bool
hasHeader String
"modified" Bool -> Bool -> Bool
|| String -> Bool
hasHeader String
"etag"
                expires :: UTCTime
expires = UTCTime -> Maybe UTCTime -> UTCTime
forall a. a -> Maybe a -> a
fromMaybe UTCTime
tombstone (String -> Maybe UTCTime
forall a. Read a => String -> Maybe a
readMaybe (String -> Maybe UTCTime) -> Maybe String -> Maybe UTCTime
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< String -> [(String, String)] -> Maybe String
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
"expires" [(String, String)]
headers)
            Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (UTCTime
now UTCTime -> UTCTime -> Bool
forall a. Ord a => a -> a -> Bool
>= UTCTime
expires Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
validatable) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
removeFile String
file

------
--- Key-value storage
------

readKV :: String -> IO (Maybe ([(String, String)], Lazy.ByteString))
writeKV :: String -> ([(String, String)], Lazy.ByteString) -> IO ()
deleteKV :: String -> IO ()
openKV :: String -> IO.IOMode -> (Handle -> IO r) -> IO (Maybe r)
pathKV :: String -> IO FilePath

pathKV :: String -> IO String
pathKV String
key = do
    String
dir <- XdgDirectory -> String -> IO String
getXdgDirectory XdgDirectory
XdgCache String
"nz.geek.adrian.hurl"
    Bool -> String -> IO ()
createDirectoryIfMissing Bool
True (String
dir String -> String -> String
</> String
"http")
    String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return (String
dir String -> String -> String
</> String
"http" String -> String -> String
</> (Char -> Bool) -> String -> String
escapeURIString Char -> Bool
isUnescapedInURIComponent String
key)

openKV :: String -> IOMode -> (Handle -> IO r) -> IO (Maybe r)
openKV String
key IOMode
mode Handle -> IO r
act = do
    String
path <- String -> IO String
pathKV String
key
    Bool
exists <- String -> IO Bool
doesFileExist String
path
    if Bool
exists then r -> Maybe r
forall a. a -> Maybe a
Just (r -> Maybe r) -> IO r -> IO (Maybe r)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IOMode -> (Handle -> IO r) -> IO r
forall r. String -> IOMode -> (Handle -> IO r) -> IO r
IO.withFile String
path IOMode
mode Handle -> IO r
act else Maybe r -> IO (Maybe r)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe r
forall a. Maybe a
Nothing

readKV :: String -> IO (Maybe ([(String, String)], ByteString))
readKV String
key = String
-> IOMode
-> (Handle -> IO ([(String, String)], ByteString))
-> IO (Maybe ([(String, String)], ByteString))
forall r. String -> IOMode -> (Handle -> IO r) -> IO (Maybe r)
openKV String
key IOMode
ReadMode Handle -> IO ([(String, String)], ByteString)
parseHeaders

parseHeaders :: Handle -> IO ([(String, String)], ByteString)
parseHeaders Handle
h = do
    String
line <- Handle -> IO String
IO.hGetLine Handle
h
    case (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
L.break Char -> Bool
isSpace (String -> (String, String)) -> String -> (String, String)
forall a b. (a -> b) -> a -> b
$ String -> String
strip' String
line of
        (String
"", String
"") -> do
            ByteString
body <- Handle -> IO ByteString
Lazy.hGetContents Handle
h
            ([(String, String)], ByteString)
-> IO ([(String, String)], ByteString)
forall (m :: * -> *) a. Monad m => a -> m a
return ([], ByteString
body)
        (String
key, String
value) -> do
            ([(String, String)]
headers, ByteString
body) <- Handle -> IO ([(String, String)], ByteString)
parseHeaders Handle
h
            ([(String, String)], ByteString)
-> IO ([(String, String)], ByteString)
forall (m :: * -> *) a. Monad m => a -> m a
return ((String
key, String -> String
strip' String
value)(String, String) -> [(String, String)] -> [(String, String)]
forall a. a -> [a] -> [a]
:[(String, String)]
headers, ByteString
body)
strip' :: String -> String
strip' = (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
L.dropWhile Char -> Bool
isSpace (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
L.dropWhileEnd Char -> Bool
isSpace

writeKV :: String -> ([(String, String)], ByteString) -> IO ()
writeKV String
key ([(String, String)]
headers, ByteString
body) = IO (Maybe ()) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Maybe ()) -> IO ()) -> IO (Maybe ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> IOMode -> (Handle -> IO ()) -> IO (Maybe ())
forall r. String -> IOMode -> (Handle -> IO r) -> IO (Maybe r)
openKV String
key IOMode
WriteMode ((Handle -> IO ()) -> IO (Maybe ()))
-> (Handle -> IO ()) -> IO (Maybe ())
forall a b. (a -> b) -> a -> b
$ \Handle
h -> do
    [(String, String)] -> ((String, String) -> IO ()) -> IO [()]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [(String, String)]
headers (((String, String) -> IO ()) -> IO [()])
-> ((String, String) -> IO ()) -> IO [()]
forall a b. (a -> b) -> a -> b
$ \(String
key, String
value) -> do
        Handle -> String -> IO ()
IO.hPutStrLn Handle
h (String
keyString -> String -> String
forall a. [a] -> [a] -> [a]
++Char
' 'Char -> String -> String
forall a. a -> [a] -> [a]
:String
value)
    Handle -> String -> IO ()
IO.hPutStrLn Handle
h String
""
    Handle -> ByteString -> IO ()
Lazy.hPut Handle
h ByteString
body

deleteKV :: String -> IO ()
deleteKV String
key = String -> IO String
pathKV String
key IO String -> (String -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= String -> IO ()
removeFile