65 lines
1.6 KiB
Haskell
65 lines
1.6 KiB
Haskell
{-# LANGUAGE NamedFieldPuns #-}
|
|
module Session (
|
|
App
|
|
, T(..)
|
|
, connection
|
|
, debug
|
|
, get
|
|
, player
|
|
, serve
|
|
, update
|
|
) where
|
|
|
|
import Data.Map ((!))
|
|
import Control.Concurrent (MVar, newMVar, modifyMVar, putMVar, readMVar, takeMVar)
|
|
import Control.Exception (finally)
|
|
import Control.Monad.Reader (ReaderT(..), ask, asks, lift)
|
|
import Network.WebSockets (Connection, ServerApp, acceptRequest)
|
|
import qualified Player (T(..), new)
|
|
import qualified Server (SessionId, T(..), join, new)
|
|
|
|
data T = T {
|
|
server :: MVar Server.T
|
|
, key :: Server.SessionId
|
|
}
|
|
|
|
type App a = ReaderT T IO a
|
|
|
|
get :: (Server.T -> a) -> App a
|
|
get f =
|
|
asks server
|
|
>>= lift . (f <$>) . readMVar
|
|
|
|
player :: App Player.T
|
|
player = do
|
|
sId <- asks key
|
|
get ((! sId) . Server.bySessionId)
|
|
|
|
connection :: App Connection
|
|
connection = Player.connection <$> player
|
|
|
|
debug :: String -> App ()
|
|
debug message =
|
|
show <$> asks Session.key
|
|
>>= lift . putStrLn . (++ ' ':message)
|
|
|
|
update :: (Server.SessionId -> Server.T -> Either String Server.T) -> App (Maybe String)
|
|
update f = do
|
|
T {server, key} <- ask
|
|
currentValue <- lift $ takeMVar server
|
|
lift $ case f key currentValue of
|
|
Left message -> putMVar server currentValue >> return (Just message)
|
|
Right updated -> putMVar server updated >> return Nothing
|
|
|
|
serve :: App () -> App () -> IO ServerApp
|
|
serve onEnter onExit = do
|
|
server <- newMVar Server.new
|
|
return $ \pending -> do
|
|
key <- acceptRequest pending
|
|
>>= return . Player.new
|
|
>>= modifyMVar server . Server.join
|
|
finally
|
|
(runReaderT onEnter $ T {server, key})
|
|
(runReaderT onExit $ T {server, key})
|
|
|