server/src/App.hs

65 lines
1.6 KiB
Haskell
Raw Normal View History

{-# 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