webwire-0.1.0: WebWire/Session.hs

-- |
-- Module:     WebWire.Session
-- Copyright:  (c) 2011 Ertugrul Soeylemez
-- License:    BSD3
-- Maintainer: Ertugrul Soeylemez <es@ertes.de>
--
-- Reactive web session handling.

module WebWire.Session
    ( -- * Sessions
      SessionCfg(..),
      WebSession,
      defSessionCfg,
      session,

      -- * Session ids
      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


-- | Session configuration.

data SessionCfg =
    SessionCfg {
      -- | Validity duration of the session cookies.
      sessDuration :: Maybe NominalDiffTime,

      -- | Threshold of saved sessions, after which sessions can be
      -- deleted.
      sessThreshold :: Int,

      -- | Minimum validitity time.  Younger sessions won't be killed on
      -- the server side.
      sessTimeLimit :: Time
    }


-- | Session identifiers.

type WebSession = ByteString


-- | Default session configuration.

defSessionCfg :: SessionCfg
defSessionCfg =
    SessionCfg { sessDuration  = Nothing,
                 sessThreshold = 1000,
                 sessTimeLimit = 7200 }


-- | Generate a new session id at every instant.

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)


-- | Get the current session id.  Inhibits, if the client didn't have
-- one.

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


-- | Reactive session handling.  The given wire is evolved for each user
-- session individually.

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')


-- | Generate a new session id and sends a cookie to the client.  The
-- input signal specifies the validity duration.  If 'Nothing', then the
-- session is valid for the duration of the browser session.

setNewSessId :: WebWire site (Maybe NominalDiffTime) ByteString
setNewSessId =
    proc validity -> do
        sessId <- genSessId -< ()
        setCookieSimple -< ("SESSION", B64.encode sessId, validity)
        identity -< sessId