{-# LANGUAGE
    OverloadedStrings
  , ConstraintKinds
  , FlexibleContexts
  , MultiParamTypeClasses
  #-}

module Application.Session where

import Application.Types

import qualified Data.TimeMap as TM
import Data.UUID (UUID)
import Data.UUID.V4 (nextRandom)
import qualified Data.ByteString.UTF8   as BS
import qualified Data.Vault.Lazy        as V
import Text.Read (readMaybe)
import Network.Wai.Trans
import Network.Wai.Session
import Network.Wai.Session.TimeMap

import Control.Concurrent.STM
import Control.Monad.IO.Class
import Control.Monad.Reader



-- * Impure

-- | Creates a new session id and increments the old value
newSessionId :: MonadApp m => m SessionId
newSessionId = do
  sidVar <- envSessionId <$> ask
  liftIO $ atomically $ do
    old <- readTVar sidVar
    modifyTVar' sidVar (+1)
    return old

-- | Creates a new nonce and session id, and updates the cache
newSession :: MonadApp m => m (SessionId, UUID)
newSession = do
  cache <- envSessionCache <$> ask
  sid   <- newSessionId
  nonce <- liftIO nextRandom
  liftIO $ TM.insert sid nonce cache
  return (sid, nonce)


currentSession :: MonadApp m => Request -> m (Maybe SessionId)
currentSession req = do
  vKey <- envSessionKey <$> ask
  return $ V.lookup vKey (vault req)

sessionCfg :: MonadApp m => m (SessionConfig IO SessionId UUID)
sessionCfg = do
  vKey  <- envSessionKey   <$> ask
  cache <- envSessionCache <$> ask
  return $ uuidSessionCfg
             (BS.fromString . show . getSessionId)
             (\s -> SessionId <$> (readMaybe $ BS.toString s :: Maybe Integer))
             "session-key"
             "session-nonce"
             vKey
             cache
