server/src/App.hs

{-# LANGUAGE NamedFieldPuns #-}
module App (
      T
    , Context(..)
    , connection
    , debug
    , get
    , current
    , server
    , try
    , update
    , update_
  ) where

import Control.Concurrent (MVar, modifyMVar, putMVar, readMVar, takeMVar)
import Control.Monad.Reader (ReaderT(..), ask, asks, lift)
import Data.Map ((!))
import Hanafuda.KoiKoi (PlayerID)
import Network.WebSockets (Connection)
import qualified Server (T(..))
import qualified Session (T(..))

data Context = Context {
      mServer :: MVar Server.T
    , playerID :: PlayerID
  }

type T a = ReaderT Context IO a

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

get :: PlayerID -> T Session.T
get playerID =
  (! playerID) . Server.sessions <$> server

current :: T Session.T
current = do
  asks playerID >>= get

connection :: T Connection
connection = Session.connection <$> current

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

try :: (Server.T -> Either String Server.T) -> T (Maybe String)
try f = do
  Context {mServer} <- ask
  currentValue <- lift $ takeMVar mServer
  lift $ case f currentValue of
    Left message -> putMVar mServer currentValue >> return (Just message)
    Right updated -> putMVar mServer updated >> return Nothing

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

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