93 lines
2.6 KiB
Haskell
93 lines
2.6 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.Set (Set, member)
|
|
import qualified Data.Set as Set (delete, empty, insert)
|
|
import Data.Text (Text)
|
|
import Hanafuda.ID (ID)
|
|
import Hanafuda.KoiKoi (PlayerID)
|
|
import Hanafuda.Message (Room)
|
|
import Keys (getKeys)
|
|
import qualified Keys (T)
|
|
import qualified RW (RW(..))
|
|
import qualified Session (ID, Status(..), T(..), Update)
|
|
|
|
type Names = Set Text
|
|
type Sessions = Map Session.ID Session.T
|
|
data T = T {
|
|
names :: Names
|
|
, players :: Room
|
|
, sessions :: Sessions
|
|
, keys :: Keys.T
|
|
}
|
|
|
|
instance RW.RW Names T where
|
|
get = names
|
|
set names server = server {names}
|
|
|
|
instance RW.RW Room 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 {
|
|
names = Set.empty
|
|
, players = Map.empty
|
|
, sessions = Map.empty
|
|
, keys
|
|
}
|
|
|
|
register :: forall a b. (Enum a, Ord a, RW.RW (Map a b) T) => b -> T -> (T, a)
|
|
register x server =
|
|
let playerID = maybe (toEnum 0) (\(n, _) -> succ n) $ lookupMax $ (RW.get server :: Map a b) in
|
|
(RW.update (insert playerID x) server, playerID)
|
|
|
|
get :: forall a b. (Ord a, RW.RW (Map a b) T) => a -> T -> b
|
|
get playerID server = (RW.get server :: Map a b) ! playerID
|
|
|
|
update :: forall a b. (Ord a, RW.RW (Map a b) T) => a -> (b -> b) -> T -> T
|
|
update playerID updator =
|
|
RW.update (adjust updator playerID :: Map a b -> Map a b)
|
|
|
|
disconnect :: Session.ID -> T -> T
|
|
disconnect sessionID =
|
|
RW.update (delete sessionID :: Sessions -> Sessions) . logOut sessionID
|
|
|
|
logIn :: Text -> PlayerID -> T -> Either String T
|
|
logIn name playerID server =
|
|
RW.update (Set.insert name) .
|
|
RW.update (insert playerID name) .
|
|
update playerID (RW.set $ Session.Status 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 ->
|
|
RW.update (delete playerID :: Room -> Room) $
|
|
update playerID (RW.set $ Session.Status False :: Session.Update) $
|
|
RW.update (Set.delete playerName :: Names -> Names) server)
|
|
(players server !? playerID)
|