79 lines
2.2 KiB
Haskell
79 lines
2.2 KiB
Haskell
{-# LANGUAGE NamedFieldPuns #-}
|
|
{-# LANGUAGE FlexibleInstances #-}
|
|
{-# LANGUAGE FlexibleContexts #-}
|
|
{-# LANGUAGE MultiParamTypeClasses #-}
|
|
{-# LANGUAGE ScopedTypeVariables #-}
|
|
module Server (
|
|
T(..)
|
|
, disconnect
|
|
, get
|
|
, logIn
|
|
, logOut
|
|
, new
|
|
, register
|
|
, update
|
|
) where
|
|
|
|
import Data.Map (Map, (!), (!?), adjust, delete, insert, lookupMax)
|
|
import qualified Data.Map as Map (empty)
|
|
import Data.Text (Text)
|
|
import Hanafuda.KoiKoi (PlayerID)
|
|
import Keys (getKeys)
|
|
import qualified Keys (T)
|
|
import qualified Player (T(..))
|
|
import qualified RW (RW(..))
|
|
import qualified Session (ID, T(..), Update)
|
|
|
|
type Players = Map PlayerID Session.ID
|
|
type Sessions = Map Session.ID Session.T
|
|
data T = T {
|
|
keys :: Keys.T
|
|
, players :: Players
|
|
, sessions :: Sessions
|
|
}
|
|
|
|
instance RW.RW Players T where
|
|
get = players
|
|
set players server = server {players}
|
|
|
|
instance RW.RW Sessions T where
|
|
get = sessions
|
|
set sessions server = server {sessions}
|
|
|
|
new :: IO T
|
|
new = getKeys >>= \keys -> return $ T {
|
|
keys
|
|
, players = Map.empty
|
|
, sessions = Map.empty
|
|
}
|
|
|
|
register :: forall a b. (Enum a, Ord a, RW.RW (Map a b) T) => b -> T -> (T, a)
|
|
register x server =
|
|
let newID = maybe (toEnum 0) (\(n, _) -> succ n) $ lookupMax $ (RW.get server :: Map a b) in
|
|
(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)
|
|
|
|
disconnect :: Session.ID -> T -> T
|
|
disconnect sessionID =
|
|
RW.update (delete sessionID :: Sessions -> Sessions) . logOut sessionID
|
|
|
|
logIn :: Text -> PlayerID -> Session.ID -> T -> T
|
|
logIn name playerID sessionID =
|
|
RW.update (insert playerID sessionID) .
|
|
update sessionID (RW.set $ Just player :: Session.Update)
|
|
where
|
|
player = Player.T {Player.playerID, Player.name}
|
|
|
|
logOut :: Session.ID -> T -> T
|
|
logOut sessionID server =
|
|
case (sessions server !? sessionID) >>= Session.player of
|
|
Nothing -> server
|
|
Just player ->
|
|
RW.update (delete (Player.playerID player) :: Players -> Players) server
|