server/src/Server.hs

{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Server (
      T(..)
    , disconnect
    , endGame
    , get
    , logIn
    , logOut
    , new
    , register
    , room
    , update
  ) where

import Data.Map (Map, (!), (!?), adjust, delete, insert, lookupMax, mapWithKey)
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.KoiKoi (Game, GameID, PlayerID)
import Hanafuda.Message (PlayerStatus(..), Room)
import qualified Data (RW(..))
import qualified Session (Status(..), T(..), Update)

type Names = Set Text
type Players = Map PlayerID Text
type Sessions = Map PlayerID Session.T
type Games = Map GameID Game
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}

export :: Sessions -> PlayerID -> Text -> PlayerStatus
export sessions playerID playerName = PlayerStatus (playerName, alone)
  where
    alone =
      case Session.status (sessions ! playerID) of
        Session.LoggedIn True -> True
        _ -> False

room :: T -> Room
room (T {players, sessions}) = 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 playerID = maybe (toEnum 0) (\(n, _) -> succ n) $ lookupMax $ (Data.get server :: Map a b) in
  (Data.update (insert playerID x) server, playerID)

get :: forall a b. (Ord a, Data.RW (Map a b) T) => a -> T -> b
get playerID server = (Data.get server :: Map a b) ! playerID

update :: forall a b. (Ord a, Data.RW (Map a b) T) => a -> (b -> b) -> T -> T
update playerID updator =
  Data.update (adjust updator playerID :: Map a b -> Map a b)

disconnect :: PlayerID -> T -> T
disconnect playerID =
  Data.update (delete playerID :: Sessions -> Sessions) . logOut playerID

endGame :: GameID -> T -> T
endGame playerID =
  Data.update (delete playerID :: Games -> Games)

logIn :: Text -> PlayerID -> T -> Either String T
logIn name playerID server =
  Data.update (Set.insert name) .
  Data.update (insert playerID name) .
  update playerID (Data.set $ Session.LoggedIn 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 ->
      Data.update (delete playerID :: Players -> Players) $
      update playerID (Data.set $ Session.LoggedIn False :: Session.Update) $
      Data.update (Set.delete playerName :: Names -> Names) server)
    (players server !? playerID)