71 lines
1.8 KiB
Haskell
71 lines
1.8 KiB
Haskell
{-# LANGUAGE NamedFieldPuns #-}
|
|
module Session (
|
|
App
|
|
, T(..)
|
|
, connection
|
|
, debug
|
|
, get
|
|
, current
|
|
, serve
|
|
, server
|
|
, try
|
|
, 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 (Key, Session(..), openSession)
|
|
import qualified Server (T(..), join, new)
|
|
|
|
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
|
|
|
|
update :: (Server.T -> Server.T) -> App ()
|
|
update f = try (Right . f) >> return ()
|
|
|
|
serve :: App () -> App () -> IO ServerApp
|
|
serve onEnter onExit = do
|
|
mServer <- newMVar Server.new
|
|
return $ \pending -> do
|
|
key <- acceptRequest pending
|
|
>>= return . Player.openSession
|
|
>>= modifyMVar mServer . Server.join
|
|
finally
|
|
(runReaderT onEnter $ T {mServer, key})
|
|
(runReaderT onExit $ T {mServer, key})
|
|
|