server/src/Server.hs

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

import Data.Map (Map, (!), (!?), adjust, delete, insert, mapMaybe)
import qualified Data.Map as Map (empty, foldlWithKey, lookup)
import Data.Text (Text)
import Hanafuda.KoiKoi (PlayerID)
import Hanafuda.Message (Room)
import Keys (getKeys)
import qualified Keys (T)
import qualified Player (T(..))
import qualified RW (RW(..))
import qualified Session (ID, T(..), setPlayer)
import System.Random (Random(..))

type SessionIDs = Map PlayerID [Session.ID]
type Sessions = Map Session.ID Session.T
data T = T {
      keys :: Keys.T
    , sessionIDsByPlayerID :: SessionIDs
    , sessions :: Sessions
  }

instance RW.RW SessionIDs T where
  get = sessionIDsByPlayerID
  set sessionIDsByPlayerID server = server {sessionIDsByPlayerID}

instance RW.RW Sessions T where
  get = sessions
  set sessions server = server {sessions}

new :: IO T
new = getKeys >>= \keys -> return $ T {
      keys
    , sessionIDsByPlayerID = Map.empty
    , sessions = Map.empty
  }

room :: T -> Room
room = mapMaybe keepName . select (\_ -> Session.player)
  where
    keepName [] = Nothing
    keepName (player:_) = Just $ Player.name player

push :: Ord k => k -> v -> Map k [v] -> Map k [v]
push key value m =
  (maybe (insert key [value]) (insert key . (value:)) $ Map.lookup key m) m

select :: (PlayerID -> Session.T -> Maybe a) -> T -> Map PlayerID [a]
select selector (T {sessionIDsByPlayerID, sessions}) =
  Map.foldlWithKey (\accumulator playerID sessionIDs ->
      foldl (\acc ->
          maybe acc (\v -> push playerID v acc) . selected playerID
        ) accumulator sessionIDs
    ) Map.empty sessionIDsByPlayerID
  where
    selected playerID sessionID =
      Map.lookup sessionID sessions >>= selector playerID

sessionsWhere :: (PlayerID -> Session.T -> Bool) -> T -> Map PlayerID [Session.T]
sessionsWhere predicate = select selectorOfPredicate where
  selectorOfPredicate playerID session =
    if predicate playerID session then Just session else Nothing

register :: forall a b. (Random a, Ord a, RW.RW (Map a b) T) => b -> T -> IO (T, a)
register x server = do
  newID <- randomIO
  return (RW.update (insert newID x) server, newID)

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

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

logIn :: Text -> PlayerID -> Session.ID -> T -> T
logIn name playerID sessionID =
  RW.update (push playerID sessionID) .
  update sessionID (Session.setPlayer playerID name)

close :: Monad m => Session.ID -> T -> m (T, Maybe PlayerID)
close sessionID server =
  return . performUpdates $ popSession sessionID server
  where
    performUpdates (updateSessionIDs, mPlayerID) = (
            RW.update (delete sessionID :: Sessions -> Sessions)
          . RW.update (updateSessionIDs :: SessionIDs -> SessionIDs) $ server
        , mPlayerID
      )

popSession :: Session.ID -> T -> (SessionIDs -> SessionIDs, Maybe PlayerID)
popSession sessionID (T {sessions, sessionIDsByPlayerID}) =
  case findPlayerID of
    Nothing -> (id, Nothing)
    Just (playerID, [_]) -> (delete playerID, Just playerID)
    Just (playerID, _) -> (purgeSession playerID, Nothing)
  where
    findPlayerID = do
      playerID <- fmap Player.playerID . Session.player =<< (sessions !? sessionID)
      (,) playerID <$> (sessionIDsByPlayerID !? playerID)
    purgeSession = adjust (filter (/= sessionID))