{-# LANGUAGE OverloadedStrings #-}
module Network.URI.Cache(shouldCacheHTTP, cacheHTTP, readCacheHTTP, cleanCacheHTTP,
    writeHSTS, readHSTS, appendHSTS, appendHSTSFromHeader, removeHSTS, testHSTS) 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, isDigit, toLower)
import Data.List as L
import Control.Monad (forM, void, when)
import Text.Read (readMaybe)

stripBS :: ByteString -> ByteString
stripBS = (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 :: forall b. 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
stripBS ([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 :: forall b. 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 :: forall a. 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 :: forall r. 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
    Bool
isEnd <- Handle -> IO Bool
IO.hIsEOF Handle
h
    if Bool
isEnd then ([(String, String)], ByteString)
-> IO ([(String, String)], ByteString)
forall (m :: * -> *) a. Monad m => a -> m a
return ([], ByteString
"") else 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

--------
---- HSTS Support
--------
readHSTS :: IO [(String, Bool, UTCTime)]
readHSTS :: IO [(String, Bool, UTCTime)]
readHSTS = do
    ([(String, String)]
headers, ByteString
_) <- ([(String, String)], ByteString)
-> Maybe ([(String, String)], ByteString)
-> ([(String, String)], ByteString)
forall a. a -> Maybe a -> a
fromMaybe ([], ByteString
"") (Maybe ([(String, String)], ByteString)
 -> ([(String, String)], ByteString))
-> IO (Maybe ([(String, String)], ByteString))
-> IO ([(String, String)], ByteString)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO (Maybe ([(String, String)], ByteString))
readKV String
".HSTS"
    -- Remove expired & duplicate entries on startup via `nubHSTS`
    UTCTime
now <- IO UTCTime
getCurrentTime
    let db :: [(String, Bool, UTCTime)]
db = UTCTime
-> [(String, Bool, UTCTime)]
-> [String]
-> [(String, Bool, UTCTime)]
forall {a} {a} {b}.
(Ord a, Eq a) =>
a -> [(a, b, a)] -> [a] -> [(a, b, a)]
nubHSTS UTCTime
now ([(String, Bool, UTCTime)] -> [(String, Bool, UTCTime)]
forall a. [a] -> [a]
L.reverse ([(String, Bool, UTCTime)] -> [(String, Bool, UTCTime)])
-> [(String, Bool, UTCTime)] -> [(String, Bool, UTCTime)]
forall a b. (a -> b) -> a -> b
$ ((String, String) -> Maybe (String, Bool, UTCTime))
-> [(String, String)] -> [(String, Bool, UTCTime)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (String, String) -> Maybe (String, Bool, UTCTime)
forall {c}. Read c => (String, String) -> Maybe (String, Bool, c)
parseRecord [(String, String)]
headers) []
    [(String, Bool, UTCTime)] -> IO ()
writeHSTS ([(String, Bool, UTCTime)] -> IO ())
-> [(String, Bool, UTCTime)] -> IO ()
forall a b. (a -> b) -> a -> b
$ Int -> [(String, Bool, UTCTime)] -> [(String, Bool, UTCTime)]
seq ([(String, Bool, UTCTime)] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
L.length [(String, Bool, UTCTime)]
db) [(String, Bool, UTCTime)]
db -- Ensure the file is fully read before being written.
    [(String, Bool, UTCTime)] -> IO [(String, Bool, UTCTime)]
forall (m :: * -> *) a. Monad m => a -> m a
return [(String, Bool, UTCTime)]
db
  where
    parseRecord :: (String, String) -> Maybe (String, Bool, c)
parseRecord (Char
'*':String
domain, String
value) | Just c
expires <- String -> Maybe c
forall a. Read a => String -> Maybe a
readMaybe String
value = (String, Bool, c) -> Maybe (String, Bool, c)
forall a. a -> Maybe a
Just (String
domain, Bool
True, c
expires)
    parseRecord (String
domain, String
value) | Just c
expires <- String -> Maybe c
forall a. Read a => String -> Maybe a
readMaybe String
value = (String, Bool, c) -> Maybe (String, Bool, c)
forall a. a -> Maybe a
Just (String
domain, Bool
False, c
expires)
    parseRecord (String, String)
_ = Maybe (String, Bool, c)
forall a. Maybe a
Nothing
appendHSTS :: (String, Bool, UTCTime) -> IO ()
appendHSTS :: (String, Bool, UTCTime) -> IO ()
appendHSTS = IO (Maybe ()) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Maybe ()) -> IO ())
-> ((String, Bool, UTCTime) -> IO (Maybe ()))
-> (String, Bool, UTCTime)
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> IOMode -> (Handle -> IO ()) -> IO (Maybe ())
forall r. String -> IOMode -> (Handle -> IO r) -> IO (Maybe r)
openKV String
".HSTS" IOMode
AppendMode ((Handle -> IO ()) -> IO (Maybe ()))
-> ((String, Bool, UTCTime) -> Handle -> IO ())
-> (String, Bool, UTCTime)
-> IO (Maybe ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Handle -> (String, Bool, UTCTime) -> IO ())
-> (String, Bool, UTCTime) -> Handle -> IO ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip Handle -> (String, Bool, UTCTime) -> IO ()
forall {a}. Show a => Handle -> (String, Bool, a) -> IO ()
appendHSTS'
appendHSTS' :: Handle -> (String, Bool, a) -> IO ()
appendHSTS' Handle
h (String
domain, Bool
True, a
expires) = Handle -> String -> IO ()
IO.hPutStrLn Handle
h (Char
'*'Char -> String -> String
forall a. a -> [a] -> [a]
:String
domain String -> String -> String
forall a. [a] -> [a] -> [a]
++ Char
' 'Char -> String -> String
forall a. a -> [a] -> [a]
:a -> String
forall a. Show a => a -> String
show a
expires)
appendHSTS' Handle
h (String
domain, Bool
False, a
expires) = Handle -> String -> IO ()
IO.hPutStrLn Handle
h (String
domain String -> String -> String
forall a. [a] -> [a] -> [a]
++ Char
' 'Char -> String -> String
forall a. a -> [a] -> [a]
:a -> String
forall a. Show a => a -> String
show a
expires)
writeHSTS :: [(String, Bool, UTCTime)] -> IO ()
writeHSTS :: [(String, Bool, UTCTime)] -> IO ()
writeHSTS [(String, Bool, UTCTime)]
domains = IO (Maybe [()]) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Maybe [()]) -> IO ())
-> ((Handle -> IO [()]) -> IO (Maybe [()]))
-> (Handle -> IO [()])
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> IOMode -> (Handle -> IO [()]) -> IO (Maybe [()])
forall r. String -> IOMode -> (Handle -> IO r) -> IO (Maybe r)
openKV String
".HSTS" IOMode
WriteMode ((Handle -> IO [()]) -> IO ()) -> (Handle -> IO [()]) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Handle
h -> [(String, Bool, UTCTime)]
-> ((String, Bool, UTCTime) -> IO ()) -> IO [()]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [(String, Bool, UTCTime)]
domains (Handle -> (String, Bool, UTCTime) -> IO ()
forall {a}. Show a => Handle -> (String, Bool, a) -> IO ()
appendHSTS' Handle
h)

-- Directly disregards IETF RFC6797 section 12.1
-- I prefer not to give up on designing a proper consent UI.
removeHSTS :: [(String, Bool, UTCTime)] -> String -> IO [(String, Bool, UTCTime)]
removeHSTS :: [(String, Bool, UTCTime)] -> String -> IO [(String, Bool, UTCTime)]
removeHSTS [(String, Bool, UTCTime)]
db String
badDomain = do
    UTCTime
now <- IO UTCTime
getCurrentTime -- Clear out expired records while we're at it...
    let ret :: [(String, Bool, UTCTime)]
ret = UTCTime
-> [(String, Bool, UTCTime)]
-> [String]
-> [(String, Bool, UTCTime)]
forall {a} {a} {b}.
(Ord a, Eq a) =>
a -> [(a, b, a)] -> [a] -> [(a, b, a)]
nubHSTS UTCTime
now [(String, Bool, UTCTime)]
db [String
badDomain]
    [(String, Bool, UTCTime)] -> IO ()
writeHSTS [(String, Bool, UTCTime)]
ret
    [(String, Bool, UTCTime)] -> IO [(String, Bool, UTCTime)]
forall (m :: * -> *) a. Monad m => a -> m a
return [(String, Bool, UTCTime)]
ret

nubHSTS :: a -> [(a, b, a)] -> [a] -> [(a, b, a)]
nubHSTS a
now (x :: (a, b, a)
x@(a
domain, b
_, a
expires):[(a, b, a)]
db) [a]
filter
    | a
domain a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`L.elem` [a]
filter = a -> [(a, b, a)] -> [a] -> [(a, b, a)]
nubHSTS a
now [(a, b, a)]
db (a
domaina -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
filter)
    -- Filter out expired entries while we're at it.
    | a
now a -> a -> Bool
forall a. Ord a => a -> a -> Bool
>= a
expires = a -> [(a, b, a)] -> [a] -> [(a, b, a)]
nubHSTS a
now [(a, b, a)]
db (a
domaina -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
filter)
    | Bool
otherwise = (a, b, a)
x(a, b, a) -> [(a, b, a)] -> [(a, b, a)]
forall a. a -> [a] -> [a]
:a -> [(a, b, a)] -> [a] -> [(a, b, a)]
nubHSTS a
now [(a, b, a)]
db (a
domaina -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
filter)
nubHSTS a
_ [] [a]
_ = []

appendHSTSFromHeader :: String -> Strict.ByteString -> IO (Maybe (String, Bool, UTCTime))
appendHSTSFromHeader :: String -> ByteString -> IO (Maybe (String, Bool, UTCTime))
appendHSTSFromHeader String
domain ByteString
header =
    let dirs :: [(String, String)]
dirs = [ByteString] -> [(String, String)]
parseDirectives ([ByteString] -> [(String, String)])
-> [ByteString] -> [(String, String)]
forall a b. (a -> b) -> a -> b
$ Char -> ByteString -> [ByteString]
C.split Char
';' ByteString
header
    in if [(String, String)] -> Bool
forall {a} {t :: * -> *}.
(Eq a, IsString a, Foldable t) =>
[(a, t Char)] -> Bool
validateHSTS [(String, String)]
dirs then do
        UTCTime
expiry <- Integer -> IO UTCTime
secondsFromNow (Integer -> IO UTCTime) -> Integer -> IO UTCTime
forall a b. (a -> b) -> a -> b
$ Integer -> Maybe Integer -> Integer
forall a. a -> Maybe a -> a
fromMaybe Integer
0 (String -> Maybe Integer
forall a. Read a => String -> Maybe a
readMaybe (String -> Maybe Integer) -> Maybe String -> Maybe Integer
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
"max-age" [(String, String)]
dirs)
        -- FIXME: Is it right I'm ignoring if this has a value.
        let subdomains :: Bool
subdomains = 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
"includesubdomains" [(String, String)]
dirs
        (String, Bool, UTCTime) -> IO ()
appendHSTS (String
domain, Bool
subdomains, UTCTime
expiry)
        Maybe (String, Bool, UTCTime) -> IO (Maybe (String, Bool, UTCTime))
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (String, Bool, UTCTime)
 -> IO (Maybe (String, Bool, UTCTime)))
-> Maybe (String, Bool, UTCTime)
-> IO (Maybe (String, Bool, UTCTime))
forall a b. (a -> b) -> a -> b
$ (String, Bool, UTCTime) -> Maybe (String, Bool, UTCTime)
forall a. a -> Maybe a
Just (String
domain, Bool
subdomains, UTCTime
expiry)
    else Maybe (String, Bool, UTCTime) -> IO (Maybe (String, Bool, UTCTime))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (String, Bool, UTCTime)
forall a. Maybe a
Nothing

parseDirectives :: [ByteString] -> [(String, String)]
parseDirectives (ByteString
dir:[ByteString]
dirs) = case (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
L.break (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'=') (String -> (String, String)) -> String -> (String, String)
forall a b. (a -> b) -> a -> b
$ ByteString -> String
C.unpack ByteString
dir of
    (String
key, Char
'=':Char
'"':String
quoted) | Just (String
value, [ByteString]
dirs') <- String -> [ByteString] -> Maybe (String, [ByteString])
parseString String
quoted [ByteString]
dirs
        -> (String -> String
lowercase (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ String -> String
strip String
key, String
value)(String, String) -> [(String, String)] -> [(String, String)]
forall a. a -> [a] -> [a]
:[ByteString] -> [(String, String)]
parseDirectives [ByteString]
dirs'
    (String
_, Char
'=':Char
'"':String
_) -> [(String
"", String
"")] -- Represents error...
    (String
key, Char
'=':String
value) -> (String -> String
lowercase (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ String -> String
strip String
key, String -> String
strip String
value)(String, String) -> [(String, String)] -> [(String, String)]
forall a. a -> [a] -> [a]
:[ByteString] -> [(String, String)]
parseDirectives [ByteString]
dirs
    (String
key, String
_) -> (String -> String
lowercase (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ String -> String
strip String
key, String
"")(String, String) -> [(String, String)] -> [(String, String)]
forall a. a -> [a] -> [a]
:[ByteString] -> [(String, String)]
parseDirectives [ByteString]
dirs
  where
    parseString :: String -> [ByteString] -> Maybe (String, [ByteString])
parseString (Char
'\\':Char
c:String
str) [ByteString]
tail = Char
-> Maybe (String, [ByteString]) -> Maybe (String, [ByteString])
forall {a} {b}. a -> Maybe ([a], b) -> Maybe ([a], b)
appendC Char
c (Maybe (String, [ByteString]) -> Maybe (String, [ByteString]))
-> Maybe (String, [ByteString]) -> Maybe (String, [ByteString])
forall a b. (a -> b) -> a -> b
$ String -> [ByteString] -> Maybe (String, [ByteString])
parseString String
str [ByteString]
tail
    parseString (String
"\"") [ByteString]
tail = (String, [ByteString]) -> Maybe (String, [ByteString])
forall a. a -> Maybe a
Just (String
"", [ByteString]
tail)
    parseString (Char
'"':String
_) [ByteString]
_ = Maybe (String, [ByteString])
forall a. Maybe a
Nothing -- Disallow trailing text
    parseString (Char
c:String
str) [ByteString]
tail = Char
-> Maybe (String, [ByteString]) -> Maybe (String, [ByteString])
forall {a} {b}. a -> Maybe ([a], b) -> Maybe ([a], b)
appendC Char
c (Maybe (String, [ByteString]) -> Maybe (String, [ByteString]))
-> Maybe (String, [ByteString]) -> Maybe (String, [ByteString])
forall a b. (a -> b) -> a -> b
$ String -> [ByteString] -> Maybe (String, [ByteString])
parseString String
str [ByteString]
tail
    -- Handle the naive split-by-semicolon above.
    parseString String
"" (ByteString
extra:[ByteString]
tail) = Char
-> Maybe (String, [ByteString]) -> Maybe (String, [ByteString])
forall {a} {b}. a -> Maybe ([a], b) -> Maybe ([a], b)
appendC Char
';' (Maybe (String, [ByteString]) -> Maybe (String, [ByteString]))
-> Maybe (String, [ByteString]) -> Maybe (String, [ByteString])
forall a b. (a -> b) -> a -> b
$ String -> [ByteString] -> Maybe (String, [ByteString])
parseString (ByteString -> String
C.unpack ByteString
extra) [ByteString]
tail
    parseString String
"" [] = Maybe (String, [ByteString])
forall a. Maybe a
Nothing
    appendC :: a -> Maybe ([a], b) -> Maybe ([a], b)
appendC a
c (Just ([a]
str, b
tail)) = ([a], b) -> Maybe ([a], b)
forall a. a -> Maybe a
Just (a
ca -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
str, b
tail)
    appendC a
_ Maybe ([a], b)
Nothing = Maybe ([a], b)
forall a. Maybe a
Nothing

    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
    lowercase :: String -> String
lowercase = (Char -> Char) -> String -> String
forall a b. (a -> b) -> [a] -> [b]
L.map Char -> Char
toLower
parseDirectives [] = []

validateHSTS :: [(a, t Char)] -> Bool
validateHSTS [(a, t Char)]
directives
    | Just t Char
_ <- a -> [(a, t Char)] -> Maybe (t Char)
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup a
"" [(a, t Char)]
directives = Bool
False -- indicates empty key or malformed string
    | Maybe (t Char)
Nothing <- a -> [(a, t Char)] -> Maybe (t Char)
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup a
"max-age" [(a, t Char)]
directives = Bool
False -- mandatory field
    | Just t Char
val <- a -> [(a, t Char)] -> Maybe (t Char)
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup a
"max-age" [(a, t Char)]
directives, (Char -> Bool) -> t Char -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
L.any (Bool -> Bool
not (Bool -> Bool) -> (Char -> Bool) -> Char -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Bool
isDigit) t Char
val = Bool
False -- invalid value
    | Bool
otherwise = [(a, t Char)] -> Bool
forall {a} {b}. Eq a => [(a, b)] -> Bool
validateHSTS' [(a, t Char)]
directives -- check no duplicate keys
validateHSTS' :: [(a, b)] -> Bool
validateHSTS' ((a
dir, b
_):[(a, b)]
dirs) | Just b
_ <- a -> [(a, b)] -> Maybe b
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup a
dir [(a, b)]
dirs = Bool
False
    | Bool
otherwise = [(a, b)] -> Bool
validateHSTS' [(a, b)]
dirs
validateHSTS' [] = Bool
True

testHSTS :: UTCTime -> String -> [(String, Bool, UTCTime)] -> Bool
testHSTS :: UTCTime -> String -> [(String, Bool, UTCTime)] -> Bool
testHSTS UTCTime
now String
key ((String
_, Bool
_, UTCTime
expires):[(String, Bool, UTCTime)]
db) | UTCTime
now UTCTime -> UTCTime -> Bool
forall a. Ord a => a -> a -> Bool
> UTCTime
expires = UTCTime -> String -> [(String, Bool, UTCTime)] -> Bool
testHSTS UTCTime
now String
key [(String, Bool, UTCTime)]
db
testHSTS UTCTime
_ String
key ((String
domain, Bool
_, UTCTime
_):[(String, Bool, UTCTime)]
db) | String
key String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
domain = Bool
True
testHSTS UTCTime
_ String
key ((String
domain, Bool
True, UTCTime
_):[(String, Bool, UTCTime)]
db) | (Char
'.'Char -> String -> String
forall a. a -> [a] -> [a]
:String
domain) String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`L.isSuffixOf` String
key = Bool
True
testHSTS UTCTime
now String
key ((String, Bool, UTCTime)
_:[(String, Bool, UTCTime)]
db) = UTCTime -> String -> [(String, Bool, UTCTime)] -> Bool
testHSTS UTCTime
now String
key [(String, Bool, UTCTime)]
db
testHSTS UTCTime
_ String
_ [] = Bool
False