124 lines
3.7 KiB
Haskell
124 lines
3.7 KiB
Haskell
{-# LANGUAGE NamedFieldPuns #-}
|
|
{-# LANGUAGE FlexibleInstances #-}
|
|
{-# LANGUAGE FlexibleContexts #-}
|
|
{-# LANGUAGE MultiParamTypeClasses #-}
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
{-# LANGUAGE ScopedTypeVariables #-}
|
|
{-# LANGUAGE AllowAmbiguousTypes #-}
|
|
module Server (
|
|
T(..)
|
|
, disconnect
|
|
, get
|
|
, logIn
|
|
, logOut
|
|
, new
|
|
, register
|
|
, update
|
|
) where
|
|
|
|
import Data.Aeson (ToJSON(..), (.=), object, pairs)
|
|
import Data.Map (Map, (!), (!?), adjust, delete, insert, lookupMax, mapWithKey)
|
|
import qualified Data.Map as Map (empty)
|
|
import Data.Monoid ((<>))
|
|
import Data.Set (Set, member)
|
|
import qualified Data.Set as Set (delete, empty, insert)
|
|
import Data.Text (Text)
|
|
import qualified Data (RW(..))
|
|
import qualified Game (Key, T(..))
|
|
import qualified Player (Key, T(..))
|
|
import qualified Session (Status(..), T(..), Update)
|
|
|
|
type Names = Set Text
|
|
type Players = Map Player.Key Player.T
|
|
type Sessions = Map Player.Key Session.T
|
|
type Games = Map Game.Key Game.T
|
|
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}
|
|
|
|
newtype Player = Player (Text, Bool)
|
|
instance ToJSON Player where
|
|
toJSON (Player (name, alone)) = object ["name" .= name, "alone" .= alone]
|
|
toEncoding (Player (name, alone)) = pairs ("name" .= name <> "alone" .= alone)
|
|
|
|
export :: Sessions -> Player.Key -> Player.T -> Player
|
|
export sessions key player = Player (Player.name player, alone)
|
|
where
|
|
alone =
|
|
case Session.status (sessions ! key) of
|
|
Session.LoggedIn True -> True
|
|
_ -> False
|
|
|
|
instance ToJSON T where
|
|
toJSON (T {players, sessions}) = toJSON $ mapWithKey (export sessions) players
|
|
toEncoding (T {players, sessions}) = toEncoding $ 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 key = maybe (toEnum 0) (\(n, _) -> succ n) $ lookupMax $ (Data.get server :: Map a b) in
|
|
(Data.update (insert key x) server, key)
|
|
|
|
get :: forall a b. (Ord a, Data.RW (Map a b) T) => a -> T -> b
|
|
get key server = (Data.get server :: Map a b) ! key
|
|
|
|
set :: forall a b c. (Ord a, Data.RW (Map a b) T, Data.RW c b) => a -> c -> T -> T
|
|
set key value = update key (Data.set value :: b -> b)
|
|
|
|
update :: forall a b. (Ord a, Data.RW (Map a b) T) => a -> (b -> b) -> T -> T
|
|
update key updator =
|
|
Data.update (adjust updator key :: Map a b -> Map a b)
|
|
|
|
disconnect :: Player.Key -> T -> T
|
|
disconnect key =
|
|
Data.update (delete key :: Sessions -> Sessions) . logOut key
|
|
|
|
logIn :: Text -> Player.Key -> T -> Either String T
|
|
logIn name key server =
|
|
Data.update (Set.insert name) .
|
|
Data.update (insert key $ Player.T {Player.name}) .
|
|
update key (Data.set $ Session.LoggedIn True :: Session.Update) <$>
|
|
if name `member` names server
|
|
then Left "This name is already registered"
|
|
else Right server
|
|
|
|
logOut :: Player.Key -> T -> T
|
|
logOut key server =
|
|
maybe
|
|
server
|
|
(\player ->
|
|
Data.update (delete key :: Players -> Players) $
|
|
update key (Data.set $ Session.LoggedIn False :: Session.Update) $
|
|
Data.update (Set.delete $ Player.name player :: Names -> Names) server)
|
|
(players server !? key)
|
|
|
|
setStatus :: Session.Status -> Player.Key -> T -> T
|
|
setStatus status key =
|
|
Data.update (adjust (Data.set status) key :: Sessions -> Sessions)
|