65 lines
1.5 KiB
Haskell
65 lines
1.5 KiB
Haskell
{-# LANGUAGE NamedFieldPuns #-}
|
|
module App (
|
|
T
|
|
, Context(..)
|
|
, connection
|
|
, debug
|
|
, get
|
|
, current
|
|
, server
|
|
, try
|
|
, update
|
|
, update_
|
|
) where
|
|
|
|
import Data.Map ((!))
|
|
import Control.Concurrent (MVar, modifyMVar, putMVar, readMVar, takeMVar)
|
|
import Control.Monad.Reader (ReaderT(..), ask, asks, lift)
|
|
import Network.WebSockets (Connection)
|
|
import qualified Player (Key)
|
|
import qualified Session (T(..))
|
|
import qualified Server (T(..))
|
|
|
|
data Context = Context {
|
|
mServer :: MVar Server.T
|
|
, key :: Player.Key
|
|
}
|
|
|
|
type T a = ReaderT Context IO a
|
|
|
|
server :: T Server.T
|
|
server = asks mServer >>= lift . readMVar
|
|
|
|
get :: Player.Key -> T Session.T
|
|
get key =
|
|
(! key) . Server.sessions <$> server
|
|
|
|
current :: T Session.T
|
|
current = do
|
|
asks key >>= get
|
|
|
|
connection :: T Connection
|
|
connection = Session.connection <$> current
|
|
|
|
debug :: String -> T ()
|
|
debug message =
|
|
show <$> asks key
|
|
>>= 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
|