{-# 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
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
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
shouldCacheHTTP :: forall b. Response b -> Bool
shouldCacheHTTP Response b
response =
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
&&
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")
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
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)
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
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])
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
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
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
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"
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
[(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)
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
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)
| 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))
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)
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
"")]
(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
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
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
| 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
| 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
| Bool
otherwise = [(a, t Char)] -> Bool
forall {a} {b}. Eq a => [(a, b)] -> Bool
validateHSTS' [(a, t Char)]
directives
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