server/src/Server.hs

{-# 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

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)