60 lines
1.4 KiB
Haskell
60 lines
1.4 KiB
Haskell
{-# LANGUAGE NamedFieldPuns #-}
|
|
module Session (
|
|
App
|
|
, T(..)
|
|
, connection
|
|
, debug
|
|
, get
|
|
, current
|
|
, server
|
|
, try
|
|
, 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, Session(..))
|
|
import qualified Server (T(..))
|
|
|
|
data T = T {
|
|
mServer :: MVar Server.T
|
|
, key :: Player.Key
|
|
}
|
|
|
|
type App a = ReaderT T IO a
|
|
|
|
server :: App Server.T
|
|
server = asks mServer >>= lift . readMVar
|
|
|
|
get :: Player.Key -> App Player.Session
|
|
get key =
|
|
(! key) . Server.sessions <$> server
|
|
|
|
current :: App Player.Session
|
|
current = do
|
|
asks key >>= get
|
|
|
|
connection :: App Connection
|
|
connection = Player.connection <$> current
|
|
|
|
debug :: String -> App ()
|
|
debug message =
|
|
show <$> asks key
|
|
>>= lift . putStrLn . (++ ' ':message)
|
|
|
|
try :: (Server.T -> Either String Server.T) -> App (Maybe String)
|
|
try f = do
|
|
T {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) -> App ()
|
|
update f = do
|
|
T {mServer} <- ask
|
|
lift $ modifyMVar_ mServer (return . f)
|