module Network.Wai.Middleware.ClientSession
( clientsession
, Word256
, defaultKeyFile
, getKey
, getDefaultKey
) where
import Prelude hiding (exp)
import Network.Wai
import Web.Encodings
import Data.List (partition)
import Data.Function.Predicate (is, isn't, equals)
import Data.Maybe (fromMaybe, mapMaybe)
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)
import qualified Data.ByteString.Char8 as B
import Control.Arrow (first)
clientsession :: [B.ByteString]
-> Word256
-> Int
-> ([(B.ByteString, B.ByteString)] -> Application)
-> Request
-> IO Response
clientsession cnames key minutesToLive app env = do
let hs = requestHeaders env
initCookiesRaw :: B.ByteString
initCookiesRaw = fromMaybe B.empty $ lookup Cookie hs
nonCookies :: [(RequestHeader, B.ByteString)]
nonCookies = filter (fst `isn't` (== Cookie)) hs
initCookies :: [(B.ByteString, B.ByteString)]
initCookies = parseCookies initCookiesRaw
cookies, interceptCookies :: [(B.ByteString, B.ByteString)]
(interceptCookies, cookies) = partition (fst `is` (`elem` cnames))
initCookies
cookiesRaw, remoteHost' :: B.ByteString
cookiesRaw = B.concat $ combineCookies cookies
remoteHost' = remoteHost env
now <- getCurrentTime
let convertedCookies :: [(B.ByteString, B.ByteString)]
convertedCookies =
mapMaybe (decodeCookie key now remoteHost') interceptCookies
let env' = env { requestHeaders =
(Cookie, cookiesRaw)
: filter (fst `equals` Cookie) (requestHeaders env)
++ nonCookies
}
res <- app convertedCookies env'
let interceptHeaders, responseHeaders' :: [(ResponseHeader, B.ByteString)]
(interceptHeaders, responseHeaders') =
partition ((responseHeaderToBS . fst) `is` (`elem` cnames))
$ responseHeaders res
interceptHeaders' :: [(B.ByteString, B.ByteString)]
interceptHeaders' = map (first responseHeaderToBS) interceptHeaders
let timeToLive :: Int
timeToLive = minutesToLive * 60
let exp = fromIntegral timeToLive `addUTCTime` now
let formattedExp = B.pack $ formatTime defaultTimeLocale "%a, %d-%b-%Y %X %Z" exp
let oldCookies :: [(B.ByteString, B.ByteString)]
oldCookies = filter
(\(k, _) -> k `notElem` map fst interceptHeaders')
convertedCookies
let newCookies = map (setCookie key exp formattedExp remoteHost') $
oldCookies ++ interceptHeaders'
let res' = res { responseHeaders = newCookies ++ responseHeaders' }
return res'
combineCookies :: [(B.ByteString, B.ByteString)] -> [B.ByteString]
combineCookies [] = []
combineCookies ((k, v):rest) = k : B.singleton '=' : v : B.pack "; "
: combineCookies rest
setCookie :: Word256
-> UTCTime
-> B.ByteString
-> B.ByteString
-> (B.ByteString, B.ByteString)
-> (ResponseHeader, B.ByteString)
setCookie key exp fexp rhost (cname, cval) =
(SetCookie, B.concat
[ cname
, B.singleton '='
, B.pack $ encrypt key $ B.pack $ show $ ACookie exp rhost cval
, B.pack "; path=/; expires="
, fexp
])
data ACookie = ACookie UTCTime B.ByteString B.ByteString
deriving (Show, Read)
decodeCookie :: Word256
-> UTCTime
-> B.ByteString
-> (B.ByteString, B.ByteString)
-> Maybe (B.ByteString, B.ByteString)
decodeCookie key now rhost (cname, encrypted) = do
decrypted <- decrypt key $ B.unpack encrypted
(ACookie exp rhost' val) <- mread $ B.unpack decrypted
guard $ exp > now
guard $ rhost' == rhost
guard $ not $ B.null 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