{-# 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 qualified Player (Key)
import qualified Session (T(..))
import qualified Server (T(..))

data Context = Context {
      mServer :: MVar Server.T
    , key :: Player.Key
  }

type T a = ReaderT Context IO a

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

get :: Player.Key -> T Session.T
get key =
  (! key) . Server.sessions <$> server

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

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

debug :: String -> T ()
debug message =
  show <$> asks key
  >>= 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