server/src/App.hs

{-# LANGUAGE NamedFieldPuns #-}
module App (
      T
    , Context(..)
    , debug
    , exec
    , server
    , session
    , update
  ) where

import Control.Concurrent (MVar, modifyMVar, readMVar)
import Control.Monad.Reader (ReaderT(..), ask, asks, lift)
import Data.Map ((!))
import qualified Server (T(..))
import qualified Session (ID, T(..))

data Context = Context {
      mServer :: MVar Server.T
    , sessionID :: Session.ID
  }

type T a = ReaderT Context IO a

server :: T Server.T
server = asks mServer >>= lift . readMVar

get :: (Server.T -> a) -> T a
get projector =
  projector <$> server

session :: T Session.T
session = do
  Context {sessionID} <- ask
  get $ (! sessionID) . Server.sessions

debug :: String -> T ()
debug message =
  show <$> asks sessionID
  >>= lift . putStrLn . (++ ' ':message)

{- Not using the previous to minimize the duration mServer gets locked -}
exec :: (Server.T -> IO (Server.T, a)) -> T a
exec f = do
  Context {mServer} <- ask
  lift $ modifyMVar mServer f

update :: (Server.T -> Server.T) -> T ()
update f = exec $ (\x -> return (x, ())) . f