server/src/Server.hs

{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE DeriveGeneric #-}
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)