module WebWire.Session
(
SessionCfg(..),
WebSession,
defSessionCfg,
session,
getSessId,
setNewSessId
)
where
import qualified Data.ByteString.Base64 as B64
import qualified Data.ByteString as B
import Control.Arrow
import Crypto.Random.AESCtr
import Data.ByteString (ByteString)
import Data.Time.Clock
import FRP.NetWire
import FRP.NetWire.Wire (mkGen)
import WebWire.Tools
import WebWire.Types
data SessionCfg =
SessionCfg {
sessDuration :: Maybe NominalDiffTime,
sessThreshold :: Int,
sessTimeLimit :: Time
}
type WebSession = ByteString
defSessionCfg :: SessionCfg
defSessionCfg =
SessionCfg { sessDuration = Nothing,
sessThreshold = 1000,
sessTimeLimit = 7200 }
genSessId :: WebWire site a ByteString
genSessId =
mkGen $ \_ _ -> do
prng' <- liftIO makeSystem
let (str, prng) = genRandomBytes prng' 32
return (Right str, genSessId' prng)
where
genSessId' :: AESRNG -> WebWire site a ByteString
genSessId' prng' =
mkGen $ \_ _ ->
let (str, prng) = genRandomBytes prng' 32 in
return (Right str, genSessId' prng)
getSessId :: WebWire site (Maybe NominalDiffTime) WebSession
getSessId =
proc validity -> do
sessIdEncoded <- getCookie -< "SESSION"
let sessIdStr = B64.decodeLenient (B.take 64 sessIdEncoded)
require_ -< B.length sessIdStr == 32
setCookieSimple -< ("SESSION", sessIdEncoded, validity)
identity -< sessIdStr
session :: SessionCfg -> WebWire site (WebSession, a) b -> WebWire site a b
session scfg userWire =
proc x' -> do
sessId <- getSessId <+> setNewSessId -< sessDuration scfg
contextLimited userWire -<
(sessThreshold scfg, sessTimeLimit scfg, sessId, x')
setNewSessId :: WebWire site (Maybe NominalDiffTime) ByteString
setNewSessId =
proc validity -> do
sessId <- genSessId -< ()
setCookieSimple -< ("SESSION", B64.encode sessId, validity)
identity -< sessId