113 lines
3.2 KiB
Haskell
113 lines
3.2 KiB
Haskell
{-# LANGUAGE NamedFieldPuns #-}
|
|
{-# LANGUAGE FlexibleInstances #-}
|
|
{-# LANGUAGE FlexibleContexts #-}
|
|
{-# LANGUAGE MultiParamTypeClasses #-}
|
|
{-# LANGUAGE ScopedTypeVariables #-}
|
|
module Server (
|
|
T(..)
|
|
, disconnect
|
|
, endGame
|
|
, get
|
|
, logIn
|
|
, logOut
|
|
, new
|
|
, register
|
|
, room
|
|
, update
|
|
) where
|
|
|
|
import Data.Map (Map, (!), (!?), adjust, delete, insert, lookupMax, mapWithKey)
|
|
import qualified Data.Map as Map (empty)
|
|
import Data.Set (Set, member)
|
|
import qualified Data.Set as Set (delete, empty, insert)
|
|
import Data.Text (Text)
|
|
import Hanafuda.KoiKoi (Game, GameID, PlayerID)
|
|
import Hanafuda.Message (PlayerStatus(..), Room)
|
|
import qualified Data (RW(..))
|
|
import qualified Session (Status(..), T(..), Update)
|
|
|
|
type Names = Set Text
|
|
type Players = Map PlayerID Text
|
|
type Sessions = Map PlayerID Session.T
|
|
type Games = Map GameID Game
|
|
data T = T {
|
|
names :: Names
|
|
, players :: Players
|
|
, sessions :: Sessions
|
|
, games :: Games
|
|
}
|
|
|
|
instance Data.RW Names T where
|
|
get = names
|
|
set names server = server {names}
|
|
|
|
instance Data.RW Players T where
|
|
get = players
|
|
set players server = server {players}
|
|
|
|
instance Data.RW Sessions T where
|
|
get = sessions
|
|
set sessions server = server {sessions}
|
|
|
|
instance Data.RW Games T where
|
|
get = games
|
|
set games server = server {games}
|
|
|
|
export :: Sessions -> PlayerID -> Text -> PlayerStatus
|
|
export sessions playerID playerName = PlayerStatus (playerName, alone)
|
|
where
|
|
alone =
|
|
case Session.status (sessions ! playerID) of
|
|
Session.LoggedIn True -> True
|
|
_ -> False
|
|
|
|
room :: T -> Room
|
|
room (T {players, sessions}) = mapWithKey (export sessions) players
|
|
|
|
new :: T
|
|
new = T {
|
|
names = Set.empty
|
|
, players = Map.empty
|
|
, sessions = Map.empty
|
|
, games = Map.empty
|
|
}
|
|
|
|
register :: forall a b. (Enum a, Ord a, Data.RW (Map a b) T) => b -> T -> (T, a)
|
|
register x server =
|
|
let playerID = maybe (toEnum 0) (\(n, _) -> succ n) $ lookupMax $ (Data.get server :: Map a b) in
|
|
(Data.update (insert playerID x) server, playerID)
|
|
|
|
get :: forall a b. (Ord a, Data.RW (Map a b) T) => a -> T -> b
|
|
get playerID server = (Data.get server :: Map a b) ! playerID
|
|
|
|
update :: forall a b. (Ord a, Data.RW (Map a b) T) => a -> (b -> b) -> T -> T
|
|
update playerID updator =
|
|
Data.update (adjust updator playerID :: Map a b -> Map a b)
|
|
|
|
disconnect :: PlayerID -> T -> T
|
|
disconnect playerID =
|
|
Data.update (delete playerID :: Sessions -> Sessions) . logOut playerID
|
|
|
|
endGame :: GameID -> T -> T
|
|
endGame playerID =
|
|
Data.update (delete playerID :: Games -> Games)
|
|
|
|
logIn :: Text -> PlayerID -> T -> Either String T
|
|
logIn name playerID server =
|
|
Data.update (Set.insert name) .
|
|
Data.update (insert playerID name) .
|
|
update playerID (Data.set $ Session.LoggedIn True :: Session.Update) <$>
|
|
if name `member` names server
|
|
then Left "This name is already registered"
|
|
else Right server
|
|
|
|
logOut :: PlayerID -> T -> T
|
|
logOut playerID server =
|
|
maybe
|
|
server
|
|
(\playerName ->
|
|
Data.update (delete playerID :: Players -> Players) $
|
|
update playerID (Data.set $ Session.LoggedIn False :: Session.Update) $
|
|
Data.update (Set.delete playerName :: Names -> Names) server)
|
|
(players server !? playerID)
|