79 lines
2.1 KiB
Haskell
79 lines
2.1 KiB
Haskell
{-# LANGUAGE NamedFieldPuns #-}
|
|
{-# LANGUAGE FlexibleInstances #-}
|
|
{-# LANGUAGE MultiParamTypeClasses #-}
|
|
module Server (
|
|
T(..)
|
|
, disconnect
|
|
, join
|
|
, logIn
|
|
, logOut
|
|
, new
|
|
, setStatus
|
|
) where
|
|
|
|
import Data.Map ((!?), Map, adjust, delete, insert, lookupMax)
|
|
import qualified Data.Map as Map (empty)
|
|
import Data.Aeson (ToJSON(..))
|
|
import qualified Data (RW(..))
|
|
import qualified Player (Key(..), Name, Session(..), Status(..))
|
|
|
|
type Keys = Map Player.Name Player.Key
|
|
type Names = Map Player.Key Player.Name
|
|
type Sessions = Map Player.Key Player.Session
|
|
data T = T {
|
|
keys :: Keys
|
|
, names :: Names
|
|
, sessions :: Sessions
|
|
}
|
|
|
|
instance Data.RW Keys T where
|
|
update f server@(T {keys}) = server {keys = f keys}
|
|
|
|
instance Data.RW Names T where
|
|
update f server@(T {names}) = server {names = f names}
|
|
|
|
instance Data.RW Sessions T where
|
|
update f server@(T {sessions}) = server {sessions = f sessions}
|
|
|
|
instance ToJSON T where
|
|
toJSON = toJSON . names
|
|
toEncoding = toEncoding . names
|
|
|
|
new :: T
|
|
new = T {
|
|
keys = Map.empty
|
|
, names = Map.empty
|
|
, sessions = Map.empty
|
|
}
|
|
|
|
join :: Player.Session -> T -> IO (T, Player.Key)
|
|
join session server@(T {sessions}) =
|
|
return (Data.update (insert key session) server, key)
|
|
where
|
|
key = Player.Key $ maybe 0 (\(Player.Key n, _) -> n+1) $ lookupMax sessions
|
|
|
|
disconnect :: Player.Key -> T -> T
|
|
disconnect key =
|
|
Data.update (delete key :: Sessions -> Sessions) . logOut key
|
|
|
|
logIn :: Player.Name -> Player.Key -> T -> Either String T
|
|
logIn name key server =
|
|
Data.update (insert name key) .
|
|
Data.update (insert key name) .
|
|
setStatus (Player.LoggedIn True) key <$>
|
|
maybe (Right server) (\_-> Left "This name is already registered") (keys server !? name)
|
|
|
|
logOut :: Player.Key -> T -> T
|
|
logOut key server =
|
|
maybe
|
|
server
|
|
(\name ->
|
|
Data.update (delete key :: Names -> Names) $
|
|
setStatus (Player.LoggedIn False) key $
|
|
Data.update (delete name :: Keys -> Keys) server)
|
|
(names server !? key)
|
|
|
|
setStatus :: Player.Status -> Player.Key -> T -> T
|
|
setStatus status key =
|
|
Data.update (adjust (Data.set status) key :: Sessions -> Sessions)
|