{-# 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 <- forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup HeaderName
hCacheControl forall a b. (a -> b) -> a -> b
$ forall body. Response body -> ResponseHeaders
responseHeaders Response b
response =
        let directives :: [ByteString]
directives = forall a b. (a -> b) -> [a] -> [b]
Prelude.map ByteString -> ByteString
stripBS forall a b. (a -> b) -> a -> b
$ Char -> ByteString -> [ByteString]
C.split Char
',' ByteString
header
        in if ByteString
key forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`Prelude.elem` [ByteString]
directives
            then forall a. a -> Maybe a
Just ByteString
""
            else forall a. [a] -> Maybe a
listToMaybe forall a b. (a -> b) -> a -> b
$ forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (ByteString -> ByteString -> Maybe ByteString
C.stripPrefix forall a b. (a -> b) -> a -> b
$ ByteString -> Char -> ByteString
C.snoc ByteString
key Char
'=') [ByteString]
directives
    | Bool
otherwise = 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 (forall body. Response body -> Status
responseStatus Response b
response) 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
        forall a. Maybe a -> Bool
isNothing (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 forall a. a -> a
id URI
uri String
""
parseHTTPTime :: String -> Maybe UTCTime
parseHTTPTime :: String -> Maybe UTCTime
parseHTTPTime String
str | Char
',' forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`L.elem` String
str = 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 = 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.
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ NominalDiffTime -> UTCTime -> UTCTime
addUTCTime (forall a. Fractional a => Rational -> a
fromRational forall a b. (a -> b) -> a -> b
$ forall a. Real a => a -> Rational
toRational 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 <- forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup HeaderName
hExpires forall a b. (a -> b) -> a -> b
$ forall body. Response body -> ResponseHeaders
responseHeaders Response a
resp,
        Just UTCTime
time <- String -> Maybe UTCTime
parseHTTPTime forall a b. (a -> b) -> a -> b
$ ByteString -> String
C.unpack ByteString
header = forall (m :: * -> *) a. Monad m => a -> m a
return UTCTime
time
  | Just ByteString
pragma <- forall b. Response b -> ByteString -> Maybe ByteString
httpCacheDirective Response a
resp ByteString
"max-age",
        Just Integer
seconds <- forall a. Read a => String -> Maybe a
readMaybe 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
60forall a. Num a => a -> a -> a
*Integer
60forall 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 | forall b. Response b -> Bool
shouldCacheHTTP Response ByteString
resp = do
    UTCTime
expires <- forall a. Response a -> IO UTCTime
computeExpires Response ByteString
resp
    let headers :: ResponseHeaders
headers = forall body. Response body -> ResponseHeaders
responseHeaders Response ByteString
resp
    String -> ([(String, String)], ByteString) -> IO ()
writeKV (URI -> String
uriToString' URI
uri) (
        [(String
"expires", forall a. Show a => a -> String
show UTCTime
expires)] forall a. [a] -> [a] -> [a]
++ forall {a}. HeaderName -> a -> [(a, String)]
getHeader HeaderName
"content-type" String
"mime" forall a. [a] -> [a] -> [a]
++
            forall {a}. HeaderName -> a -> [(a, String)]
getHeader HeaderName
"ETag" String
"etag" forall a. [a] -> [a] -> [a]
++ forall {a}. HeaderName -> a -> [(a, String)]
getHeader HeaderName
"Last-Modified" String
"modified",
        forall body. Response body -> body
responseBody Response ByteString
resp)
  where
    getHeader :: HeaderName -> a -> [(a, String)]
getHeader HeaderName
header a
key | Just ByteString
value <- forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup HeaderName
header forall a b. (a -> b) -> a -> b
$ forall body. Response body -> ResponseHeaders
responseHeaders Response ByteString
resp = [(a
key, ByteString -> String
C.unpack ByteString
value)]
        | Bool
otherwise = []
cacheHTTP URI
_ Response ByteString
_ = 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 ResponseHeaders)
readCacheHTTP URI
uri = do
    Maybe ([(String, String)], ByteString)
cached <- String -> IO (Maybe ([(String, String)], ByteString))
readKV 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 <- forall a. Read a => String -> Maybe a
readMaybe forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
"expires" [(String, String)]
headers -> do
            let mime :: String
mime = forall a. a -> Maybe a -> a
fromMaybe String
"application/octet-stream" forall a b. (a -> b) -> a -> b
$ 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 ResponseHeaders
headers' = if UTCTime
expiry forall a. Ord a => a -> a -> Bool
<= UTCTime
now then forall a. Maybe a
Nothing else forall a. a -> Maybe a
Just (
                    [(HeaderName
"If-Modified-Since", String -> ByteString
C.pack String
val) | (String
"modified", String
val) <- [(String, String)]
headers,
                        forall a. Maybe a -> Bool
isJust forall a b. (a -> b) -> a -> b
$ String -> Maybe UTCTime
parseHTTPTime String
val] 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.
            forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall a. Maybe a -> Bool
isJust Maybe ResponseHeaders
headers') forall a b. (a -> b) -> a -> b
$ String -> IO ()
deleteKV forall a b. (a -> b) -> a -> b
$ URI -> String
uriToString' URI
uri

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

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

cleanCacheHTTP :: IO ()
cleanCacheHTTP = forall (f :: * -> *) a. Functor f => f a -> f ()
void 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 forall (m :: * -> *) a. Monad m => a -> m a
return []
    forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [String]
files forall a b. (a -> b) -> a -> b
$ \String
file -> do
        Bool
exists <- String -> IO Bool
doesFileExist String
file
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
exists forall a b. (a -> b) -> a -> b
$ forall r. String -> IOMode -> (Handle -> IO r) -> IO r
IO.withFile String
file IOMode
ReadMode 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 = forall a. Maybe a -> Bool
isJust forall a b. (a -> b) -> a -> b
$ 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 = forall a. a -> Maybe a -> a
fromMaybe UTCTime
tombstone (forall a. Read a => String -> Maybe a
readMaybe forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
"expires" [(String, String)]
headers)
            forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (UTCTime
now forall a. Ord a => a -> a -> Bool
>= UTCTime
expires Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
validatable) 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")
    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 forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall r. String -> IOMode -> (Handle -> IO r) -> IO r
IO.withFile String
path IOMode
mode Handle -> IO r
act else forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing

readKV :: String -> IO (Maybe ([(String, String)], ByteString))
readKV String
key = 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 forall (m :: * -> *) a. Monad m => a -> m a
return ([], ByteString
"") else do
        String
line <- Handle -> IO String
IO.hGetLine Handle
h
        case forall a. (a -> Bool) -> [a] -> ([a], [a])
L.break Char -> Bool
isSpace 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
                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
                forall (m :: * -> *) a. Monad m => a -> m a
return ((String
key, String -> String
strip' String
value)forall a. a -> [a] -> [a]
:[(String, String)]
headers, ByteString
body)
strip' :: String -> String
strip' = forall a. (a -> Bool) -> [a] -> [a]
L.dropWhile Char -> Bool
isSpace forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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) = forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall r. String -> IOMode -> (Handle -> IO r) -> IO (Maybe r)
openKV String
key IOMode
WriteMode forall a b. (a -> b) -> a -> b
$ \Handle
h -> do
    forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [(String, String)]
headers forall a b. (a -> b) -> a -> b
$ \(String
key, String
value) -> do
        Handle -> String -> IO ()
IO.hPutStrLn Handle
h (String
keyforall a. [a] -> [a] -> [a]
++Char
' '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 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
_) <- forall a. a -> Maybe a -> a
fromMaybe ([], 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 = forall {a} {a} {b}.
(Ord a, Eq a) =>
a -> [(a, b, a)] -> [a] -> [(a, b, a)]
nubHSTS UTCTime
now (forall a. [a] -> [a]
L.reverse forall a b. (a -> b) -> a -> b
$ forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe forall {c}. Read c => (String, String) -> Maybe (String, Bool, c)
parseRecord [(String, String)]
headers) []
    [(String, Bool, UTCTime)] -> IO ()
writeHSTS forall a b. (a -> b) -> a -> b
$ seq :: forall a b. a -> b -> b
seq (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.
    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 <- forall a. Read a => String -> Maybe a
readMaybe String
value = forall a. a -> Maybe a
Just (String
domain, Bool
True, c
expires)
    parseRecord (String
domain, String
value) | Just c
expires <- forall a. Read a => String -> Maybe a
readMaybe String
value = forall a. a -> Maybe a
Just (String
domain, Bool
False, c
expires)
    parseRecord (String, String)
_ = forall a. Maybe a
Nothing
appendHSTS :: (String, Bool, UTCTime) -> IO ()
appendHSTS :: (String, Bool, UTCTime) -> IO ()
appendHSTS = forall (f :: * -> *) a. Functor f => f a -> f ()
void forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall r. String -> IOMode -> (Handle -> IO r) -> IO (Maybe r)
openKV String
".HSTS" IOMode
AppendMode forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. (a -> b -> c) -> b -> a -> c
flip 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
'*'forall a. a -> [a] -> [a]
:String
domain forall a. [a] -> [a] -> [a]
++ Char
' 'forall a. a -> [a] -> [a]
: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 forall a. [a] -> [a] -> [a]
++ Char
' 'forall a. a -> [a] -> [a]
:forall a. Show a => a -> String
show a
expires)
writeHSTS :: [(String, Bool, UTCTime)] -> IO ()
writeHSTS :: [(String, Bool, UTCTime)] -> IO ()
writeHSTS [(String, Bool, UTCTime)]
domains = forall (f :: * -> *) a. Functor f => f a -> f ()
void forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall r. String -> IOMode -> (Handle -> IO r) -> IO (Maybe r)
openKV String
".HSTS" IOMode
WriteMode forall a b. (a -> b) -> a -> b
$ \Handle
h -> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [(String, Bool, UTCTime)]
domains (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 = 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
    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 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
domainforall a. a -> [a] -> [a]
:[a]
filter)
    -- Filter out expired entries while we're at it.
    | a
now 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
domainforall a. a -> [a] -> [a]
:[a]
filter)
    | Bool
otherwise = (a, b, a)
xforall a. a -> [a] -> [a]
:a -> [(a, b, a)] -> [a] -> [(a, b, a)]
nubHSTS a
now [(a, b, a)]
db (a
domainforall 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 forall a b. (a -> b) -> a -> b
$ Char -> ByteString -> [ByteString]
C.split Char
';' ByteString
header
    in if 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 forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a -> a
fromMaybe Integer
0 (forall a. Read a => String -> Maybe a
readMaybe forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< 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 = forall a. Maybe a -> Bool
isJust forall a b. (a -> b) -> a -> b
$ 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)
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just (String
domain, Bool
subdomains, UTCTime
expiry)
    else forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing

parseDirectives :: [ByteString] -> [(String, String)]
parseDirectives (ByteString
dir:[ByteString]
dirs) = case forall a. (a -> Bool) -> [a] -> ([a], [a])
L.break (forall a. Eq a => a -> a -> Bool
== Char
'=') 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 forall a b. (a -> b) -> a -> b
$ String -> String
strip String
key, String
value)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 forall a b. (a -> b) -> a -> b
$ String -> String
strip String
key, String -> String
strip String
value)forall a. a -> [a] -> [a]
:[ByteString] -> [(String, String)]
parseDirectives [ByteString]
dirs
    (String
key, String
_) -> (String -> String
lowercase forall a b. (a -> b) -> a -> b
$ String -> String
strip String
key, 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 = forall {a} {b}. a -> Maybe ([a], b) -> Maybe ([a], b)
appendC Char
c forall a b. (a -> b) -> a -> b
$ String -> [ByteString] -> Maybe (String, [ByteString])
parseString String
str [ByteString]
tail
    parseString (String
"\"") [ByteString]
tail = forall a. a -> Maybe a
Just (String
"", [ByteString]
tail)
    parseString (Char
'"':String
_) [ByteString]
_ = forall a. Maybe a
Nothing -- Disallow trailing text
    parseString (Char
c:String
str) [ByteString]
tail = forall {a} {b}. a -> Maybe ([a], b) -> Maybe ([a], b)
appendC Char
c 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) = forall {a} {b}. a -> Maybe ([a], b) -> Maybe ([a], b)
appendC Char
';' forall a b. (a -> b) -> a -> b
$ String -> [ByteString] -> Maybe (String, [ByteString])
parseString (ByteString -> String
C.unpack ByteString
extra) [ByteString]
tail
    parseString String
"" [] = forall a. Maybe a
Nothing
    appendC :: a -> Maybe ([a], b) -> Maybe ([a], b)
appendC a
c (Just ([a]
str, b
tail)) = forall a. a -> Maybe a
Just (a
cforall a. a -> [a] -> [a]
:[a]
str, b
tail)
    appendC a
_ Maybe ([a], b)
Nothing = forall a. Maybe a
Nothing

    strip :: String -> String
strip = forall a. (a -> Bool) -> [a] -> [a]
L.dropWhile Char -> Bool
isSpace forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
L.dropWhileEnd Char -> Bool
isSpace
    lowercase :: String -> String
lowercase = 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
_ <- 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 <- 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 <- forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup a
"max-age" [(a, t Char)]
directives, forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
L.any (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Bool
isDigit) t Char
val = Bool
False -- invalid value
    | Bool
otherwise = 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
_ <- 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 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 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
'.'forall a. a -> [a] -> [a]
:String
domain) 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