module Hack.Middleware.ClientSession
( clientsession
, Word256
, defaultKeyFile
, getKey
, getDefaultKey
) where
import Prelude hiding (exp)
import Hack
import Web.Encodings
import Data.List (partition, intercalate)
import Data.Function.Predicate (is, isn't, equals)
import Data.Maybe (fromMaybe)
import Web.ClientSession
import Data.Time.Clock (getCurrentTime, UTCTime, addUTCTime)
import Data.Time.LocalTime ()
import Data.Time.Format (formatTime)
import System.Locale (defaultTimeLocale)
import Control.Monad (guard)
clientsession :: [String]
-> Word256
-> Middleware
clientsession cnames key app env = do
let initCookiesRaw :: String
initCookiesRaw = fromMaybe "" $ lookup "Cookie" $ http env
nonCookies :: [(String, String)]
nonCookies = filter (fst `isn't` (== "Cookie")) $ http env
initCookies :: [(String, String)]
initCookies = decodeCookies initCookiesRaw
cookies, interceptCookies :: [(String, String)]
(interceptCookies, cookies) = partition (fst `is` (`elem` cnames))
initCookies
cookiesRaw :: String
cookiesRaw = intercalate "; " $ map (\(k, v) -> k ++ "=" ++ v)
cookies
remoteHost :: String
remoteHost = fromMaybe "" $ lookup "REMOTE_HOST" $ http env
now <- getCurrentTime
let convertedCookies =
takeJusts $
map (decodeCookie key now remoteHost) interceptCookies
let env' = env { http = ("Cookie", cookiesRaw)
: filter (fst `equals` "Cookie") (http env)
++ nonCookies
, hackHeaders = hackHeaders env ++ convertedCookies
}
res <- app env'
let (interceptHeaders, headers') = partition (fst `is` (`elem` cnames))
$ headers res
let twentyMinutes :: Int
twentyMinutes = 20 * 60
let exp = fromIntegral twentyMinutes `addUTCTime` now
let formattedExp = formatTime defaultTimeLocale "%a, %d-%b-%Y %X %Z" exp
let oldCookies = filter (\(k, _) -> not $ k `elem` map fst interceptHeaders) convertedCookies
let newCookies = map (setCookie key exp formattedExp remoteHost) $
oldCookies ++ interceptHeaders
let res' = res { headers = newCookies ++ headers' }
return res'
takeJusts :: [Maybe a] -> [a]
takeJusts [] = []
takeJusts (Just x:rest) = x : takeJusts rest
takeJusts (Nothing:rest) = takeJusts rest
setCookie :: Word256
-> UTCTime
-> String
-> String
-> (String, String) -> (String, String)
setCookie key exp fexp rhost (cname, cval) =
("Set-Cookie", cname ++ "=" ++ val ++ "; path=/; expires=" ++ fexp)
where
val = encrypt key $ show $ Cookie exp rhost cval
data Cookie = Cookie UTCTime String String deriving (Show, Read)
decodeCookie :: Word256
-> UTCTime
-> String
-> (String, String)
-> Maybe (String, String)
decodeCookie key now rhost (cname, encrypted) = do
decrypted <- decrypt key encrypted
(Cookie exp rhost' val) <- mread decrypted
guard $ exp > now
guard $ rhost' == rhost
guard $ val /= ""
return (cname, val)
mread :: (Monad m, Read a) => String -> m a
mread s =
case reads s of
[] -> fail $ "Reading of " ++ s ++ " failed"
((x, _):_) -> return x