73 lines
2.3 KiB
Haskell
73 lines
2.3 KiB
Haskell
{-# LANGUAGE NamedFieldPuns #-}
|
|
{-# LANGUAGE FlexibleInstances #-}
|
|
{-# LANGUAGE TypeSynonymInstances #-}
|
|
{-# LANGUAGE MultiParamTypeClasses #-}
|
|
module Server (
|
|
SessionId
|
|
, T(..)
|
|
, disconnect
|
|
, join
|
|
, logIn
|
|
, logOut
|
|
, new
|
|
) where
|
|
|
|
import Data.Vector (fromList)
|
|
import Data.Aeson (ToJSON(..), Value(Array))
|
|
import Data.Map ((!), (!?), Map, adjust, delete, elems, empty, insert, lookupMax)
|
|
import qualified Data (RW(..))
|
|
import qualified Player (Login(..), Name(..), T(..))
|
|
|
|
newtype SessionId = SessionId Int deriving (Eq, Ord, Read, Show)
|
|
type Players = Map SessionId Player.T
|
|
type SessionIds = Map Player.Name SessionId
|
|
data T = T {
|
|
byName :: SessionIds
|
|
, bySessionId :: Players
|
|
}
|
|
|
|
instance Data.RW SessionIds T where
|
|
update f server@(T {byName}) = server {byName = f byName}
|
|
|
|
instance Data.RW Players T where
|
|
update f server@(T {bySessionId}) = server {bySessionId = f bySessionId}
|
|
|
|
loggedInPlayers :: T -> [Player.T]
|
|
loggedInPlayers (T {byName, bySessionId}) =
|
|
[(bySessionId ! sessionId) | sessionId <- elems byName]
|
|
|
|
instance ToJSON T where
|
|
toJSON = Array . fromList . (toJSON <$>) . loggedInPlayers
|
|
toEncoding = toEncoding . loggedInPlayers
|
|
|
|
new :: T
|
|
new = T {
|
|
byName = empty
|
|
, bySessionId = empty
|
|
}
|
|
|
|
join :: Player.T -> T -> IO (T, SessionId)
|
|
join player server@(T {bySessionId}) =
|
|
return (Data.update (insert sessionId player) server, sessionId)
|
|
where
|
|
sessionId = SessionId $ maybe 0 (\(SessionId n, _) -> n+1) $ lookupMax bySessionId
|
|
|
|
disconnect :: SessionId -> T -> Either String T
|
|
disconnect sessionId server =
|
|
Data.update (delete sessionId :: Players -> Players) <$> logOut sessionId server
|
|
|
|
logIn :: Player.Name -> SessionId -> T -> Either String T
|
|
logIn name sessionId server =
|
|
Data.update (adjust (Data.set (Player.Login name) :: Player.T -> Player.T) sessionId) <$>
|
|
Data.update (insert name sessionId) <$>
|
|
maybe (Right server) (\_ -> Left "This name is already registered") maybeName
|
|
where
|
|
maybeName = byName server !? name
|
|
|
|
logOut :: SessionId -> T -> Either String T
|
|
logOut sessionId server@(T {bySessionId}) =
|
|
Right $ Data.update (adjust (Data.set Player.Anonymous :: Player.T -> Player.T) sessionId) $
|
|
(case Player.login $ bySessionId ! sessionId of
|
|
(Player.Login name) -> Data.update (delete name :: SessionIds -> SessionIds) server
|
|
Player.Anonymous -> server)
|