{-# LANGUAGE NamedFieldPuns #-}
module App (
      T
    , Context(..)
    , connection
    , debug
    , get
    , current
    , server
    , try
    , update
    , update_
  ) where

import Data.Map ((!))
import Control.Concurrent (MVar, modifyMVar, putMVar, readMVar, takeMVar)
import Control.Monad.Reader (ReaderT(..), ask, asks, lift)
import Network.WebSockets (Connection)
import Hanafuda.KoiKoi (PlayerID)
import qualified Session (T(..))
import qualified Server (T(..))

data Context = Context {
      mServer :: MVar Server.T
    , playerID :: PlayerID
  }

type T a = ReaderT Context IO a

server :: T Server.T
server = asks mServer >>= lift . readMVar

get :: PlayerID -> T Session.T
get playerID =
  (! playerID) . Server.sessions <$> server

current :: T Session.T
current = do
  asks playerID >>= get

connection :: T Connection
connection = Session.connection <$> current

debug :: String -> T ()
debug message =
  show <$> asks playerID
  >>= lift . putStrLn . (++ ' ':message)

try :: (Server.T -> Either String Server.T) -> T (Maybe String)
try f = do
  Context {mServer} <- ask
  currentValue <- lift $ takeMVar mServer
  lift $ case f currentValue of
    Left message -> putMVar mServer currentValue >> return (Just message)
    Right updated -> putMVar mServer updated >> return Nothing

{- Not using the previous to minimize the duration mServer gets locked -}
update :: (Server.T -> (Server.T, a)) -> T a
update f = do
  Context {mServer} <- ask
  lift $ modifyMVar mServer (return . f)

update_ :: (Server.T -> Server.T) -> T ()
update_ f = update $ (\x -> (x, ())) . f