State.hs

module Dingo.Internal.Server.State
       ( ClientSession
       , ServerSessionState
       , ServerState
       , SessionId
       , cssClientSessionState
       , emptyServerState
       , getSession
       , getSessionId
       , handleCallback
       , readCommandWithTimeout
       , ssApplicationTitle
       , ssBootResourceBundles
       ) where

import           Control.Concurrent.Chan.Strict (Chan, newChan, writeChan)
import           Control.DeepSeq.ByteString ()
import           Control.Monad (replicateM)
import           Data.Aeson (Value(..))
import           Data.ByteString (ByteString)
import qualified Data.ByteString as BS
import qualified Data.ByteString.Base64 as B64
import qualified Data.Foldable as F
import           Data.HashMap.Strict (HashMap)
import           Data.IORef (IORef, atomicModifyIORef, newIORef, readIORef)
import qualified Data.Label as L
import           Data.Map (Map)
import qualified Data.Map as M
import           Data.Text (Text)
import           Dingo.Internal.Application (mkApplication, Application)
import           Dingo.Internal.Base (CallbackId, WidgetId)
import           Dingo.Internal.CallbackTypes (WrapCallback(..), CallbackM, mkSession, getCommands)
import           Dingo.Internal.JavaScript (renderCommandsToJs)
import           Dingo.Internal.Queue (readChanTimeout)
import           Dingo.Internal.ResourceBundle.Boot (bootResourceBundles)
import           Dingo.Internal.Session (SessionState, runSessionT, runCallback)
import           Dingo.ResourceBundle (ResourceBundle)
import           System.Random (Random(randomRIO))

-- Session ID identifies a session, i.e. identifies a client persistently
-- across requests.
type SessionId = ByteString

-- Type alias for shorter function signatures.
type ServerSessionState = SessionState WrapCallback

-- Client session state.
data ClientSessionState =
  ClientSessionState { _cssClientSessionState :: ServerSessionState
                     , _cssCommandsForClient :: Chan ByteString
                     }

$(L.mkLabels [''ClientSessionState])

-- Type alias for convenience.
-- TODO: We should probably make this abstract
type ClientSession = (SessionId, IORef ClientSessionState)

-- Server state.
data ServerState =
  ServerState { _ssClientSessions :: IORef (Map SessionId (IORef ClientSessionState))
              , _ssApplicationCallback :: CallbackM ()
              , _ssApplicationTitle :: Text
              , _ssBootResourceBundles :: [ResourceBundle]
              }

$(L.mkLabels [''ServerState])

-- Empty server state.
emptyServerState :: (Application -> CallbackM ()) -> Text -> [ResourceBundle] -> IO ServerState
emptyServerState applicationCallback applicationTitle resourceBundles = do
  clientSessions <- newIORef M.empty
  return $ ServerState clientSessions (applicationCallback mkApplication) applicationTitle (bootResourceBundles ++ resourceBundles)

-- Generate a session ID.
generateSessionId :: IO ByteString
generateSessionId = fmap toBase64 $ replicateM 16 $ randomRIO (0,255)
  where
    toBase64 = B64.encode . BS.pack . map fromInteger

-- Find or initialize session. If the returned session ID
-- does not match the input session ID, a new session was
-- created.
getSession :: ServerState -> Maybe SessionId -> IO ClientSession
getSession serverState mSessionId = do
  serverStateM <- readIORef $ L.get ssClientSessions serverState
  case mSessionId of
    Nothing -> newSession
    Just sessionId ->
      case M.lookup sessionId serverStateM of
        Nothing -> newSession
        Just sessionRef -> return (sessionId, sessionRef) -- Exists

  where

    newSession :: IO ClientSession
    newSession = do
      -- Generate a new session ID.
      sessionId <- generateSessionId
      -- Start up new session.
      let app = L.get ssApplicationCallback serverState
      let bundles = L.get ssBootResourceBundles serverState
      let sessionState = mkSession app bundles
      sessionChannel <- newChan
      sessionRef <- newIORef $ ClientSessionState sessionState sessionChannel
      -- Add session to the server state.
      atomicModifyIORef (L.get ssClientSessions serverState)
        (\m -> (M.insert sessionId sessionRef m, ()))
      -- Return the reference to the session.
      return (sessionId, sessionRef)

-- Get session ID.
getSessionId :: ClientSession -> SessionId
getSessionId = fst

-- Handle a callback.
handleCallback :: ClientSession -> CallbackId -> HashMap WidgetId Value -> IO ()
handleCallback clientSession callbackId widgetStates = do
  -- Get the session reference.
  let clientSessionRef = snd clientSession
  session <- readIORef clientSessionRef
  -- Handle the request.
  let sessionState = L.get cssClientSessionState session
  (callbackState,sessionState') <-
    runSessionT sessionState $ runCallback callbackId widgetStates
  let commands = getCommands callbackState
  -- Add commands to the channel.
  let commandsChan = L.get cssCommandsForClient session
  writeChan commandsChan $ renderCommandsToJs $ F.toList commands
  -- Update the session reference.
  atomicModifyIORef clientSessionRef (\_ -> (ClientSessionState sessionState' commandsChan, ()))

-- Wait for a command to appear in the queue.
readCommandWithTimeout :: ServerState -> ClientSession -> Int -> IO (Maybe ByteString)
readCommandWithTimeout serverState clientSession timeout = do
  serverStateM <- readIORef $ L.get ssClientSessions serverState
  case M.lookup clientSessionId serverStateM of
    Nothing -> return Nothing
    Just sessionRef -> do
      commandsChan <- fmap (L.get cssCommandsForClient) $ readIORef sessionRef
      readChanTimeout commandsChan timeout

  where

    clientSessionId = fst clientSession