118 lines
3.7 KiB
Haskell
118 lines
3.7 KiB
Haskell
{-# LANGUAGE NamedFieldPuns #-}
|
|
{-# LANGUAGE FlexibleInstances #-}
|
|
{-# LANGUAGE FlexibleContexts #-}
|
|
{-# LANGUAGE MultiParamTypeClasses #-}
|
|
{-# LANGUAGE ScopedTypeVariables #-}
|
|
module Server (
|
|
T(..)
|
|
, close
|
|
, get
|
|
, logIn
|
|
, new
|
|
, register
|
|
, room
|
|
, select
|
|
, sessionsWhere
|
|
, update
|
|
) where
|
|
|
|
import Data.Map (Map, (!), (!?), adjust, delete, insert, mapMaybe)
|
|
import qualified Data.Map as Map (empty, foldlWithKey, lookup)
|
|
import Data.Text (Text)
|
|
import Hanafuda.KoiKoi (PlayerID)
|
|
import Hanafuda.Message (Room)
|
|
import Keys (getKeys)
|
|
import qualified Keys (T)
|
|
import qualified Player (T(..))
|
|
import qualified RW (RW(..))
|
|
import qualified Session (ID, T(..), setPlayer)
|
|
import System.Random (Random(..))
|
|
|
|
type SessionIDs = Map PlayerID [Session.ID]
|
|
type Sessions = Map Session.ID Session.T
|
|
data T = T {
|
|
keys :: Keys.T
|
|
, sessionIDsByPlayerID :: SessionIDs
|
|
, sessions :: Sessions
|
|
}
|
|
|
|
instance RW.RW SessionIDs T where
|
|
get = sessionIDsByPlayerID
|
|
set sessionIDsByPlayerID server = server {sessionIDsByPlayerID}
|
|
|
|
instance RW.RW Sessions T where
|
|
get = sessions
|
|
set sessions server = server {sessions}
|
|
|
|
new :: IO T
|
|
new = getKeys >>= \keys -> return $ T {
|
|
keys
|
|
, sessionIDsByPlayerID = Map.empty
|
|
, sessions = Map.empty
|
|
}
|
|
|
|
room :: T -> Room
|
|
room = mapMaybe keepName . select (\_ -> Session.player)
|
|
where
|
|
keepName [] = Nothing
|
|
keepName (player:_) = Just $ Player.name player
|
|
|
|
push :: Ord k => k -> v -> Map k [v] -> Map k [v]
|
|
push key value m =
|
|
(maybe (insert key [value]) (insert key . (value:)) $ Map.lookup key m) m
|
|
|
|
select :: (PlayerID -> Session.T -> Maybe a) -> T -> Map PlayerID [a]
|
|
select selector (T {sessionIDsByPlayerID, sessions}) =
|
|
Map.foldlWithKey (\accumulator playerID sessionIDs ->
|
|
foldl (\acc ->
|
|
maybe acc (\v -> push playerID v acc) . selected playerID
|
|
) accumulator sessionIDs
|
|
) Map.empty sessionIDsByPlayerID
|
|
where
|
|
selected playerID sessionID =
|
|
Map.lookup sessionID sessions >>= selector playerID
|
|
|
|
sessionsWhere :: (PlayerID -> Session.T -> Bool) -> T -> Map PlayerID [Session.T]
|
|
sessionsWhere predicate = select selectorOfPredicate where
|
|
selectorOfPredicate playerID session =
|
|
if predicate playerID session then Just session else Nothing
|
|
|
|
register :: forall a b. (Random a, Ord a, RW.RW (Map a b) T) => b -> T -> IO (T, a)
|
|
register x server = do
|
|
newID <- randomIO
|
|
return (RW.update (insert newID x) server, newID)
|
|
|
|
get :: forall a b. (Ord a, RW.RW (Map a b) T) => a -> T -> b
|
|
get keyID server = (RW.get server :: Map a b) ! keyID
|
|
|
|
update :: forall a b. (Ord a, RW.RW (Map a b) T) => a -> (b -> b) -> T -> T
|
|
update keyID updator =
|
|
RW.update (adjust updator keyID :: Map a b -> Map a b)
|
|
|
|
logIn :: Text -> PlayerID -> Session.ID -> T -> T
|
|
logIn name playerID sessionID =
|
|
RW.update (push playerID sessionID) .
|
|
update sessionID (Session.setPlayer playerID name)
|
|
|
|
close :: Monad m => Session.ID -> T -> m (T, Maybe PlayerID)
|
|
close sessionID server =
|
|
return . performUpdates $ popSession sessionID server
|
|
where
|
|
performUpdates (updateSessionIDs, mPlayerID) = (
|
|
RW.update (delete sessionID :: Sessions -> Sessions)
|
|
. RW.update (updateSessionIDs :: SessionIDs -> SessionIDs) $ server
|
|
, mPlayerID
|
|
)
|
|
|
|
popSession :: Session.ID -> T -> (SessionIDs -> SessionIDs, Maybe PlayerID)
|
|
popSession sessionID (T {sessions, sessionIDsByPlayerID}) =
|
|
case findPlayerID of
|
|
Nothing -> (id, Nothing)
|
|
Just (playerID, [_]) -> (delete playerID, Just playerID)
|
|
Just (playerID, _) -> (purgeSession playerID, Nothing)
|
|
where
|
|
findPlayerID = do
|
|
playerID <- fmap Player.playerID . Session.player =<< (sessions !? sessionID)
|
|
(,) playerID <$> (sessionIDsByPlayerID !? playerID)
|
|
purgeSession = adjust (filter (/= sessionID))
|